├── .gitignore ├── README.md ├── overview.png ├── project.clj └── src └── async_ui ├── core.clj ├── ex_master_detail.clj ├── ex_table.clj ├── forml.clj ├── javafx ├── application.clj ├── binding.clj ├── builder.clj ├── tk.clj └── utils.clj ├── main.clj └── swing ├── binding.clj ├── builder.clj └── tk.clj /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /lib 3 | /classes 4 | /checkouts 5 | /bin 6 | /doc 7 | /.settings 8 | pom.xml 9 | pom.xml.asc 10 | *~ 11 | *.jar 12 | *.class 13 | /.lein-* 14 | /.nrepl-port 15 | .project 16 | .classpath 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # async-ui 2 | 3 | A prototype demonstrating JavaFX or Swing GUI programming with clojure.core.async. 4 | 5 | Here's a working [example](src/async_ui/ex_master_detail.clj). 6 | 7 | ## What it shows 8 | 9 | * A UI form with all its state represented by pure data. 10 | * Specification of UI forms and event processing is free of access to 11 | JavaFX APIs, and can therefore be tested without any GUI test robots. 12 | * Event processing and communication among UI forms is free of 13 | callbacks or direct thread-handling, and uses core.async channels 14 | instead. 15 | 16 | ## Overview 17 | 18 | ![Overview](overview.png) 19 | 20 | A *View* is a map that contains a specification of the visual 21 | component tree, the domain data, a mapping between both, validation 22 | rules and validation results (for more details see the Concepts 23 | section). This data represents the state of a UI form. Each view has 24 | it's own events channel. For each view, one process is started using 25 | the `run-view` function, which processes events for that view. "Event 26 | processing" means that the data contained in the event is merged into 27 | the view state, validation is applied, an individual handler is 28 | invoked and the resulting view is passed via a central channel to 29 | another process that is responsible for synchronization with the UI 30 | Toolkit. 31 | 32 | As mentioned in the previous paragraph there is a single toolkit 33 | oriented process, started via `run-tk`, which processes views it 34 | receives via a central channel. "Processing a view" means initially to 35 | actually create the visual component tree using the UI 36 | Toolkit. Further updates of the view are processed by writing the data 37 | from the view into the property values of the visual components. 38 | 39 | The concrete UI toolkit like JavaFX or Swing is hidden behind the 40 | *Toolkit* protocol. It is mainly implemented by a builder and a 41 | binding. The builder takes views specification of a form and produces 42 | a visual component tree. The binding registers listeners that put an 43 | event onto the views own events channel and creates setters that 44 | update the visual components properties with the data contained in the 45 | view. 46 | 47 | 48 | ## Concepts 49 | 50 | A *Spec* is a map representing a UI form. A spec can be created with expressions 51 | like this: 52 | ```clojure 53 | (window "Item Editor" 54 | :content 55 | (panel "Content" :lygeneral "wrap 2, fill" :lycolumns "[|100,grow]" 56 | :components 57 | [(label "Text") (textfield "text" :lyhint "growx") 58 | (panel "Actions" :lygeneral "ins 0" :lyhint "span, right" 59 | :components 60 | [(button "OK") (button "Cancel")])])) 61 | ``` 62 | 63 | A *Component Path* is a vector of visual component names. 64 | 65 | 66 | A *Property Path* is a component path conj'ed with a keyword 67 | representing a property within a visual component. 68 | 69 | 70 | A *Mapping* is a vector of maps. 71 | Each of these maps contains 72 | 73 | - :data-path -- A vector or single keyword pointing to a piece of data in a map 74 | - :property-path -- A vector consisting of a Component Path conj'ed with a keyword 75 | denoting the property in the visual component. 76 | - :formatter -- A function converting from a value to a human readable text 77 | - :parser -- A function converting a human readable text to a value 78 | 79 | 80 | A *View* is a map containing all data necessary for a UI form and the 81 | visual component tree. 82 | 83 | - :id -- A string uniquely identifing this view 84 | - :spec -- A model of the form (see forml namespace for the metamodel) 85 | - :vc -- The tree of visual components 86 | - :data -- A map with all domain and view-state data of the form 87 | - :mapping -- A vector of mappings between visual component 88 | properties and data in the :data map 89 | - :events -- The channel for receiving events 90 | - :setter-fns -- A map of data-path to 1-arg functions used to update 91 | visual component properties values 92 | - :validation-rule-set -- A vector of validation rules (see examine library) 93 | - :validation-results -- Current validation results (see examine library) 94 | 95 | A view is created like so: 96 | 97 | ```clojure 98 | (defn item-editor-view 99 | [data] 100 | (-> (v/make-view "item-editor" 101 | (window "Item Editor" 102 | :content 103 | (panel "Content" :lygeneral "wrap 2, fill" :lycolumns "[|100,grow]" 104 | :components 105 | [(label "Text") (textfield "text" :lyhint "growx") 106 | (panel "Actions" :lygeneral "ins 0" :lyhint "span, right" 107 | :components 108 | [(button "OK") (button "Cancel")])]))) 109 | (assoc :mapping (v/make-mapping :text ["text" :text]) 110 | :validation-rule-set (e/rule-set :text (c/min-length 1)) 111 | :data data))) 112 | ``` 113 | 114 | 115 | An *Event* is a map with keys 116 | 117 | - :source -- Points to a visual components property or other source 118 | - :type -- A keyword denoting the type of event. 119 | Common event types are :update or :action. 120 | - :payload -- Arbitrary data 121 | 122 | 123 | An *Event Handler* is a function that is invoked by the view process to 124 | process an event and possibly create a new version of the view. 125 | 126 | Here's an example of a simple event handler: 127 | 128 | ```clojure 129 | (defn item-editor-handler 130 | [view event] 131 | (go (case ((juxt :source :type) event) 132 | ["OK" :action] 133 | (assoc view :terminated true) 134 | ["Cancel" :action] 135 | (assoc view 136 | :terminated true 137 | :cancelled true) 138 | view))) 139 | ``` 140 | 141 | A *Component Map* contains all visual components indexed by their 142 | corresponding component paths. 143 | 144 | 145 | A *Toolkit* provides uniform access to functionalities of Swing or JavaFX. 146 | 147 | ```clojure 148 | (defprotocol Toolkit 149 | (run-now [tk f] 150 | "Executes function f in toolkits event processing thread.") 151 | (show-view! [tk view] 152 | "Makes the root of the visual component tree visible.") 153 | (hide-view! [tk view] 154 | "Makes the root of the visual component tree invisible.") 155 | (build-vc-tree [tk view] 156 | "Creates a visual component tree from the data in the :spec slot of the view. 157 | Returns the view with an updated :vc slot.") 158 | (bind-vc-tree! [tk view] 159 | "Attaches listeners to visual components that put events to the :events channel of the view. 160 | Returns the view with :setter-fns slot updated.") 161 | (vc-name [tk vc] 162 | "Returns the name of the visual component.") 163 | (vc-children [tk vc] 164 | "Returns a seq with the children of the visual component or [] if it doesn't have any.") 165 | (set-vc-error! [tk vc msgs] 166 | "Updates the error state of a visual component according to the messages seq msgs. 167 | Empty msgs remove the error state.")) 168 | ``` 169 | 170 | ## Adding visual component types 171 | 172 | This prototype supports only a small number of component types. To 173 | add support for a type of visual component one has to add at least one 174 | datatype in src/async_ui/forml.clj with corresponding defaults. 175 | 176 | To support a type of visual component within a specific toolkit there 177 | are three methods to add: 178 | 179 | * `build` in builder.clj that produces a component instance from the 180 | spec. 181 | * `bind!` in binding.clj that registers event listeners that put 182 | events to the views `:events` channel. 183 | * `setter-fns` in binding.clj that returns a map of component specific 184 | functions that update a property of component from a value. 185 | 186 | 187 | ## Usage 188 | 189 | Make sure you're on JDK 1.8.0_25. Clone this project. 190 | 191 | ### REPL 192 | 193 | * Open the file `src/async_ui/ex_master_detail.clj` and compile it. 194 | * `(do (ns async-ui.ex-master-detail) (start!))` 195 | 196 | ### Standalone 197 | 198 | * You can run the application using `lein run`. 199 | * Alternatively you can create an all-in-one Jar using `lein uberjar` 200 | and execute the resulting Jar (`java -jar ...`). 201 | 202 | NOTE: For some weird technical reasons JavaFX needs to have its 203 | Application Thread started for some of the classes to be loaded 204 | properly. In other words, the compilation process starts a JavaFX 205 | thread, which blocks JVM termination after compilation finished. As a 206 | remedy, an environment var in the uberjar profile is used to detect 207 | compilation and a `Platform/exit` is issued after some seconds, but 208 | termination still takes about 1 minute. Be patient. 209 | 210 | NOTE: If you start the Jar from the project directory with 211 | `java -jar target/async-ui-0.1.0-SNAPSHOT-standalone.jar` make sure 212 | you delete .lein-env beforehand. 213 | 214 | Currently there is no proper application exit. Ctrl-C helps. 215 | 216 | 217 | ## License 218 | 219 | Copyright 2014 F.Riemenschneider 220 | 221 | Distributed under the Eclipse Public License, the same as Clojure. 222 | -------------------------------------------------------------------------------- /overview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/friemen/async-ui/ee57f2a3f04cc5b64165d1c59b9ef68b2b3937b1/overview.png -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject async-ui "0.1.0-SNAPSHOT" 2 | :description "Demonstrating how to apply core.async to rich clients" 3 | :url "http://example.com/FIXME" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [[org.clojure/clojure "1.6.0"] 7 | [org.clojure/core.async "0.1.346.0-17112a-alpha"] 8 | [metam/core "1.0.5"] 9 | [parsargs "1.2.0"] 10 | [examine "1.2.0"] 11 | [environ "1.0.0"] 12 | ;; Swing 13 | [com.miglayout/miglayout-swing "5.0"] 14 | ;; JavaFX 15 | [com.miglayout/miglayout-javafx "5.0"]] 16 | :main async-ui.main 17 | :plugins [[lein-environ "1.0.0"]] 18 | :profiles {:uberjar {:aot :all 19 | :env {:javafx-exit true}}} 20 | :repositories [["sonatype" {:url "https://oss.sonatype.org/content/repositories/snapshots" 21 | :snapshots true}]]) 22 | -------------------------------------------------------------------------------- /src/async_ui/core.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.core 2 | (:require [clojure.core.async :as async :refer [go go-loop put! ! close!]] 3 | [parsargs.core :as p] 4 | [examine.core :as e])) 5 | 6 | 7 | ; ------------------------------------------------------------------------------ 8 | ;; Utilities 9 | 10 | (def logging-on true) 11 | 12 | (defn log [& xs] (when logging-on (apply println xs)) (last xs)) 13 | 14 | (defn as-vector [x] 15 | (cond 16 | (vector? x) x 17 | (coll? x) (vec x) 18 | :else (vector x))) 19 | 20 | ; ------------------------------------------------------------------------------ 21 | ;; Global state 22 | 23 | (defonce views (atom {})) 24 | 25 | (defonce tk-ch (atom nil)) 26 | 27 | 28 | ; ------------------------------------------------------------------------------ 29 | ;; A View is a map containing all data necessary for a UI view and the 30 | ;; visual component tree. 31 | ;; - :id A string uniquely identifing this view 32 | ;; - :spec A model of the form (see forml namespace) 33 | ;; - :vc The tree of visual components 34 | ;; - :data A map with all domain and view-state data of the form 35 | ;; - :mapping A vector of mappings between visual component 36 | ;; properties and data in the :data map 37 | ;; - :events The channel for receiving events 38 | ;; - :setter-fns A map of data-path to 1-arg functions used to update 39 | ;; visual component properties values 40 | ;; - :validation-rule-set A vector of validation rules (see examine library) 41 | ;; - :validation-results Current validation results (see examine library) 42 | 43 | (defn make-view 44 | "Creates a map representing a View." 45 | [id spec] 46 | {:id id 47 | :spec spec 48 | :vc nil 49 | :data {} 50 | :mapping [] 51 | :events (async/chan) 52 | :setter-fns {} 53 | :validation-rule-set [] 54 | :validation-results {}}) 55 | 56 | 57 | ; ------------------------------------------------------------------------------ 58 | ;; An Event is a map with keys 59 | ;; - :source points to a visual components property or other source 60 | ;; - :type is a keyword denoting the type of event. 61 | ;; common event types are :update or :action 62 | ;; - :payload is arbitrary data 63 | 64 | (defn make-event 65 | "Creates and returns a map representing an Event. 66 | Used by Toolkit bindings." 67 | ([source type] 68 | (make-event source type nil)) 69 | ([source type payload] 70 | {:source source 71 | :type type 72 | :payload payload}) 73 | ([source property type payload] 74 | {:source [source property] 75 | :type type 76 | :payload payload})) 77 | 78 | 79 | ; ------------------------------------------------------------------------------ 80 | ;; A Mapping is a vector of maps. 81 | ;; Each of these maps contains 82 | ;; - :data-path a vector or single keyword pointing to a piece of data in a map 83 | ;; - :property-path a vector consisting of a Component Path conj'ed with a keyword 84 | ;; denoting the property in the visual component. 85 | ;; - :formatter a function converting from a value to a human readable text 86 | ;; - :parser a function converting a human readable text to a value 87 | 88 | (def ^:private mapping-parser 89 | (p/some 90 | (p/sequence :data-path (p/alternative 91 | (p/value vector?) 92 | (p/value keyword?)) 93 | :property-path (p/value #(and (vector? %) 94 | (every? string? (drop-last %)) 95 | (keyword? (last %)))) 96 | :formatter (p/optval fn? identity) 97 | :parser (p/optval fn? identity)))) 98 | 99 | 100 | (defn make-mapping 101 | "Returns a new Mapping vector from the arguments. 102 | Example: 103 | (make-mapping :foo [\"panel\" :text]) 104 | results in 105 | [{:parser identity, 106 | :formatter identity, 107 | :property-path [\"Panel\" \"Foo\" :text], 108 | :data-path :foo}]." 109 | [& args] 110 | (p/parse mapping-parser args)) 111 | 112 | 113 | (defn- matches-property-path? 114 | [event-source property-path] 115 | (if (vector? event-source) 116 | (= (reverse event-source) (->> property-path reverse (take 2))) 117 | (= event-source (->> property-path reverse second)))) 118 | 119 | 120 | ; ---------------------------------------------------------------------------- 121 | ;; A Toolkit provides uniform access to functionalities of Swing or JavaFX. 122 | 123 | (defprotocol Toolkit 124 | (run-now [tk f] 125 | "Executes function f in toolkits event processing thread.") 126 | (show-view! [tk view] 127 | "Makes the root of the visual component tree visible.") 128 | (hide-view! [tk view] 129 | "Makes the root of the visual component tree invisible.") 130 | (build-vc-tree [tk view] 131 | "Creates a visual component tree from the data in the :spec slot of the view. 132 | Returns the view with an updated :vc slot.") 133 | (bind-vc-tree! [tk view] 134 | "Attaches listeners to visual components that put events to the :events channel of the view. 135 | Returns the view with :setter-fns slot updated.") 136 | (vc-name [tk vc] 137 | "Returns the name of the visual component.") 138 | (vc-children [tk vc] 139 | "Returns a seq with the children of the visual component or [] if it doesn't have any.") 140 | (set-vc-error! [tk vc msgs] 141 | "Updates the error state of a visual component according to the messages seq msgs. 142 | Empty msgs remove the error state.")) 143 | 144 | 145 | ; ------------------------------------------------------------------------------ 146 | ;; A Component Path is a vector of visual component names. 147 | ;; A Component Map contains all visual components indexed by their 148 | ;; corresponding component paths. 149 | 150 | (defn- component-map 151 | "Returns a map from Component Path to visual component by 152 | traversing the visual component tree represented by it's root vc." 153 | [tk vc] 154 | (let [walk (fn walk [parent-path vc] 155 | (let [path (conj parent-path (vc-name tk vc))] 156 | (cons 157 | (vector path vc) 158 | (mapcat (partial walk path) (vc-children tk vc)))))] 159 | (into {} (walk [] vc)))) 160 | 161 | 162 | (defn- find-by-path 163 | "Returns the first visual component whose component path matches 164 | the given suffix." 165 | [comp-map path-suffix] 166 | (->> comp-map 167 | (filter #(every? true? (map = (reverse (first %)) (reverse (as-vector path-suffix))))) 168 | first 169 | second)) 170 | 171 | 172 | (defn setter-map 173 | "Returns a map {data-path -> setter}. The setter is a 1-arg function 174 | that retrieves the value from the data map arg according to the data-path of 175 | the mapping and writes the formatted value to mapped component property. 176 | Used by toolkit bindings." 177 | [tk vc update-fns mapping] 178 | (let [setter-fn-map (into {} (for [[cpath vc] (component-map tk vc), 179 | [key setter-fn] (update-fns vc)] 180 | [(conj cpath key) setter-fn]))] 181 | (into {} 182 | (for [{:keys [data-path property-path formatter]} mapping] 183 | (if-let [setter-fn (find-by-path setter-fn-map property-path)] 184 | [data-path (fn set-value! [old-data data] 185 | (let [data-path (as-vector data-path) 186 | old-value (get-in old-data data-path) 187 | new-value (get-in data data-path)] 188 | (when (not= old-value new-value) 189 | (log "run-tk: Set data" new-value "from" data-path) 190 | (-> new-value formatter setter-fn))))]))))) 191 | 192 | 193 | ; ---------------------------------------------------------------------------- 194 | ;; Toolkit process 195 | 196 | (defn- shutdown-view! 197 | "Hides a view, closes its :events channel." 198 | [tk view] 199 | (log "run-tk: Shutting down view" (:id view)) 200 | (close! (:events view)) 201 | (hide-view! tk view) 202 | view) 203 | 204 | 205 | (defn- create-vc-tree! 206 | "Builds and binds a view." 207 | [tk view] 208 | {:pre [(:spec view) 209 | (:id view)] 210 | :post [(:vc %)]} 211 | (if (or (nil? (:vc view)) (:rebuild view)) 212 | (do (log "run-tk: Must build new visual component tree for" (:id view)) 213 | (->> view 214 | (build-vc-tree tk) 215 | (bind-vc-tree! tk))) 216 | view)) 217 | 218 | 219 | (defn- update-data-in-vc-tree! 220 | "Calls all update functions in the view to put the views data 221 | into the visual component tree." 222 | [current-view {:keys [id setter-fns data] :as new-view}] 223 | {:pre [id data setter-fns]} 224 | (let [old-data (:data current-view)] 225 | (when (or (:rebuild new-view) (not= old-data data)) 226 | (log "run-tk: Updating data in visual components of" id ": " data) 227 | (doseq [setter (vals setter-fns)] 228 | (setter old-data data))) 229 | (dissoc new-view :rebuild))) 230 | 231 | 232 | (defn- display-validation-results! 233 | "Takes :validation-results from view and sets validation error state 234 | in all visual components that are mentioned in the :mapping of the view." 235 | [tk view] 236 | {:pre [(:mapping view) 237 | (:validation-results view) 238 | (:vc view)]} 239 | (let [msg-map (into {} 240 | (for [{:keys [data-path property-path]} (:mapping view), 241 | :let [msgs (-> view :validation-results e/messages (get data-path))]] 242 | [property-path msgs])) 243 | comp-map (component-map tk (:vc view))] 244 | (doseq [[property-path msgs] msg-map] 245 | (set-vc-error! tk 246 | (find-by-path comp-map (drop-last property-path)) 247 | msgs)) 248 | view)) 249 | 250 | 251 | (defn- synchronize-ui! 252 | "Creates and updates or removes the view." 253 | [tk current-view new-view] 254 | {:pre [(:id new-view) 255 | (:events new-view)]} 256 | (run-now tk 257 | (fn [] 258 | (if (:terminated new-view) 259 | (swap! views dissoc (:id (shutdown-view! tk new-view))) 260 | (swap! views assoc (:id new-view) (->> new-view 261 | (create-vc-tree! tk) 262 | (update-data-in-vc-tree! current-view) 263 | (display-validation-results! tk))))))) 264 | 265 | 266 | (defn run-tk 267 | "Asynchronous process that waits for a view on the toolkit channel 268 | and synchronizes it's state with the UI toolkit." 269 | [tk] 270 | (if-not @tk-ch 271 | (do 272 | (reset! tk-ch (async/chan)) 273 | (go-loop [] 274 | (try (let [view-msg (> mapping 309 | (filter #(matches-property-path? (:source event) (:property-path %))) 310 | first)) 311 | 312 | 313 | (defn- update-view 314 | "Updates a view from an event and validates its data. 315 | If the event is nil or of type :close then [:terminated true] is added. 316 | Returns an updated view." 317 | [view event] 318 | {:pre [(:data view)] 319 | :post [(:data %)]} 320 | (condp = (if event (:type event) :close) 321 | :update (if-let [m (mapping-for-event (:mapping view) event)] 322 | (let [data (assoc-in (:data view) 323 | (-> m :data-path as-vector) 324 | ((:parser m) (:payload event))) 325 | vrs (e/validate (-> view :validation-rule-set (e/sub-set (:data-path m))) data)] 326 | (assoc view 327 | :data data 328 | :validation-results (merge (:validation-results view) vrs))) 329 | view) 330 | :close (assoc view :terminated (or (:terminated view) (= :close (:type event)))) 331 | view)) 332 | 333 | 334 | (defn- install-automatic-rebuild! 335 | "Adds a watch on the factory function var that causes a rebuild of 336 | the visual component tree. Enables interactive UI form development 337 | in the REPL." 338 | [view-factory-var initial-data] 339 | (add-watch view-factory-var 340 | :rebuild 341 | (fn [k r o new-factory] 342 | (let [new-view (new-factory initial-data) 343 | old-view (@views (:id new-view))] 344 | (put! @tk-ch [(dissoc old-view :data) 345 | (assoc new-view 346 | :rebuild true 347 | :events (:events old-view) 348 | :vc (:vc old-view) 349 | :data (:data old-view))]))))) 350 | 351 | 352 | (defn run-view 353 | "Asynchronous process that waits for events on the views :events channel, 354 | processes the event (update of data, validation, further actions represented 355 | by the handler-fn-var), and finally pushes the resulting view onto the central 356 | toolkit channel." 357 | [view-factory-var handler-fn-var initial-data] 358 | {:pre [@tk-ch]} 359 | (install-automatic-rebuild! view-factory-var initial-data) 360 | (go-loop [old-view nil 361 | view (@view-factory-var initial-data)] 362 | (let [view-id (:id view)] 363 | (>! @tk-ch [old-view view]) 364 | (if-not (:terminated view) 365 | (let [event (!] :as async] 3 | [examine.core :as e] 4 | [examine.constraints :as c] 5 | [async-ui.forml :refer :all] 6 | [async-ui.core :as v] 7 | [async-ui.javafx.tk :as javafx] 8 | [async-ui.swing.tk :as swing])) 9 | 10 | 11 | ; ---------------------------------------------------------------------------- 12 | ;; TODOs 13 | ;; - Replace tk/bind-vc-tree with tk/setters and tk/bind-events! 14 | ;; - Replace tk/build-vc-tree with tk/build 15 | ;; - Consider if build should do a diff+merge 16 | ;; - view setter-fns should contain property-path -> setter as well as data-path -> setter 17 | ;; - Instead of tk/set-vc-error use a setter-fn for a :message 18 | ;; - Demonstrate testing support with event recording and play-back 19 | ;; - Improve interactive development 20 | ;; - Properly display validation messages 21 | ;; - Introduce modality between windows 22 | 23 | ; ---------------------------------------------------------------------------- 24 | ;; In the REPL: 25 | ;; Compile this namespace. 26 | 27 | ;; Run this snippet to start master with JavaFX 28 | #_ (do (ns async-ui.ex-master-detail) (start!)) 29 | 30 | 31 | ;; To just start the toolkit process with JavaFX 32 | #_(do 33 | (ns async-ui.ex-master-detail) 34 | (def javafx-tk (javafx/make-toolkit)) 35 | (v/run-tk javafx-tk)) 36 | 37 | ;; Start only process for master view 38 | #_(v/run-view #'item-manager-view 39 | #'item-manager-handler 40 | {:item "" 41 | :items ["Foo" "Bar" "Baz"]}) 42 | 43 | ;; We could start the process for the details view directly 44 | #_(v/run-view #'item-editor-view 45 | #'item-editor-handler 46 | {:text "Foo"}) 47 | 48 | ;; Terminate Toolkit process 49 | #_(v/stop-tk) 50 | 51 | 52 | ; ---------------------------------------------------------------------------- 53 | ;; A Detail View 54 | 55 | (defn item-editor-view 56 | [data] 57 | (-> (v/make-view "item-editor" 58 | (window "Item Editor" 59 | :content 60 | (panel "Content" :lygeneral "wrap 2, fill" :lycolumns "[|100,grow]" 61 | :components 62 | [(label "Text") (textfield "text" :lyhint "growx") 63 | (panel "Actions" :lygeneral "ins 0" :lyhint "span, right" 64 | :components 65 | [(button "OK") (button "Cancel")])]))) 66 | (assoc :mapping (v/make-mapping :text ["text" :text]) 67 | :validation-rule-set (e/rule-set :text (c/min-length 1)) 68 | :data data))) 69 | 70 | (defn item-editor-handler 71 | [view event] 72 | (go (case ((juxt :source :type) event) 73 | ["OK" :action] 74 | (assoc view :terminated true) 75 | 76 | ["Cancel" :action] 77 | (assoc view 78 | :terminated true 79 | :cancelled true) 80 | view))) 81 | 82 | 83 | ; ---------------------------------------------------------------------------- 84 | ;; A Master View 85 | 86 | (defn item-manager-view 87 | [data] 88 | (let [spec 89 | (window "Item Manager" 90 | :content 91 | (panel "Content" :lygeneral "wrap 2, fill" :lycolumns "[|100,grow]" :lyrows "[|200,grow|]" 92 | :components 93 | [(label "Item") (textfield "item" :lyhint "growx") 94 | (listbox "items" :lyhint "span, grow") 95 | (panel "Actions" :lygeneral "ins 0" :lyhint "span, right" 96 | :components 97 | [(button "Add Item") 98 | (button "Edit Item") 99 | (button "Remove Item") 100 | (button "Run Action")])]))] 101 | (-> (v/make-view "item-manager" spec) 102 | (assoc :mapping (v/make-mapping :item ["item" :text] 103 | :items ["items" :items] 104 | :selection ["items" :selection]) 105 | :data data)))) 106 | 107 | (defn replace-at 108 | [xs n ys] 109 | (vec (concat (take n xs) 110 | ys 111 | (drop (inc n) xs)))) 112 | 113 | 114 | (defn item-manager-handler 115 | [view event] 116 | (go (assoc view 117 | :data 118 | (let [data (:data view)] 119 | (case ((juxt :source :type) event) 120 | 121 | ["Calc" :finished] 122 | (update-in data [:items] conj "Calc finished!") 123 | 124 | ["Run Action" :action] 125 | (do (future 126 | (Thread/sleep 2000) 127 | (async/>!! (:events view) {:source "Calc" :type :finished})) 128 | data) 129 | 130 | ["Add Item" :action] 131 | (-> data 132 | (update-in [:items] conj (:item data)) 133 | (assoc :item "")) 134 | 135 | ["Edit Item" :action] 136 | (let [index (or (first (:selection data)) -1) 137 | items (:items data)] 138 | (if (and (not= index -1) (< index (count items))) 139 | (let [editor-view ( editor-view :data :text)])) 145 | data)) 146 | data)) 147 | 148 | ["Remove Item" :action] 149 | (assoc data 150 | :items (let [items (:items data) 151 | index (or (first (:selection data)) -1)] 152 | (if (and (not= index -1) (< index (count items))) 153 | (replace-at items index []) 154 | items))) 155 | data))))) 156 | 157 | 158 | 159 | ; ---------------------------------------------------------------------------- 160 | ;; Startup 161 | 162 | 163 | (defn start! 164 | [] 165 | (v/run-tk (javafx/make-toolkit)) 166 | (v/run-view #'item-manager-view 167 | #'item-manager-handler 168 | {:item "" 169 | :items (vec (take 100 (repeatedly #(rand-nth ["Foo" "Bar" "Baz"]))))})) 170 | 171 | -------------------------------------------------------------------------------- /src/async_ui/ex_table.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.ex-table 2 | (:require [clojure.core.async :refer [go !] :as async] 3 | [async-ui.forml :refer :all] 4 | [async-ui.core :as v] 5 | [async-ui.javafx.tk :as javafx] 6 | [async-ui.swing.tk :as swing])) 7 | 8 | 9 | 10 | (defn table-view 11 | [data] 12 | (-> (v/make-view 13 | "table-demo" 14 | (window "Table Demo" :content 15 | (panel "Content" :lygeneral "fill" 16 | :components 17 | [(table "Contacts" 18 | :columns 19 | [(column "Name") 20 | (column "Street") 21 | (column "City")])]))) 22 | (assoc :data data 23 | :mapping (v/make-mapping :contacts ["Contacts" :items] 24 | :selected ["Contacts" :selection])))) 25 | 26 | 27 | (defn table-view-handler 28 | [view event] 29 | (go view)) 30 | 31 | 32 | (defn start! [] 33 | (v/run-view #'table-view 34 | #'table-view-handler 35 | {:contacts (vec (repeat 10 {:name "foo" :street "bar" :city "baz"})) 36 | :selected [0]})) 37 | -------------------------------------------------------------------------------- /src/async_ui/forml.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.forml 2 | (:require [clojure.string :as s] 3 | [metam.core :refer :all])) 4 | 5 | (declare defaults) 6 | 7 | (defmetamodel forml 8 | (-> (make-hierarchy) 9 | (derive ::container ::component) 10 | (derive ::widget ::component) 11 | 12 | ; concrete component types 13 | (derive ::button ::widget) 14 | (derive ::label ::widget) 15 | (derive ::listbox ::labeled) 16 | (derive ::listbox ::widget) 17 | (derive ::listbox ::growing) 18 | (derive ::panel ::growing) 19 | (derive ::panel ::container) 20 | (derive ::table ::labeled) 21 | (derive ::table ::widget) 22 | (derive ::table ::growing) 23 | (derive ::textfield ::labeled) 24 | (derive ::textfield ::widget)) 25 | {::button {:text [string?] 26 | :lyhint [string?] 27 | :icon [string?]} 28 | ::column {:title [string?] 29 | :getter [#(or (fn? %) (keyword? %))]} 30 | ::label {:text [string?] 31 | :lyhint [string?] 32 | :icon [string?]} 33 | ::listbox {:label [string?] 34 | :lyhint [string?] 35 | :labelyhint [string?]} 36 | ::panel {:lygeneral [string?] 37 | :lycolumns [string?] 38 | :lyrows [string?] 39 | :lyhint [string?] 40 | :components [(coll (type-of ::component))]} 41 | ::table {:label [string?] 42 | :lyhint [string?] 43 | :labelyhint [string?] 44 | :columns [(coll (type-of ::column))]} 45 | ::textfield {:label [string?] 46 | :lyhint [string?] 47 | :labelyhint [string?]} 48 | ::window {:title [string?] 49 | :content [(type-of ::container)] 50 | :owner [] 51 | :modality [(value-of :none :window :application)]}} 52 | #'defaults) 53 | 54 | 55 | (defdefaults defaults forml 56 | {:default nil 57 | [::button :text] (:name spec) 58 | [::column :title] (:name spec) 59 | [::column :getter] (-> spec :name s/lower-case keyword) 60 | [::growing :lyhint] "grow" 61 | [::labeled :labelyhint] "" 62 | [::labeled :label] (:name spec) 63 | [::label :text] (:name spec) 64 | [::panel :lyrows] "" 65 | [::panel :lycolumns] "" 66 | [::widget :lyhint] "" 67 | [::window :title] (:name spec) 68 | [::window :owner] nil 69 | [::window :modality] :none}) 70 | 71 | (prefer-method defaults [::growing :lyhint] [::widget :lyhint]) 72 | -------------------------------------------------------------------------------- /src/async_ui/javafx/application.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.javafx.application 2 | "JavaFX Startup utilities" 3 | (:import [javafx.application Application]) 4 | (:gen-class 5 | :extends javafx.application.Application)) 6 | 7 | (defonce root-stage (promise)) 8 | 9 | (defn -start 10 | [this stage] 11 | (deliver root-stage stage)) 12 | -------------------------------------------------------------------------------- /src/async_ui/javafx/binding.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.javafx.binding 2 | (:require [clojure.core.async :refer [put!]] 3 | [async-ui.core :refer [make-event]]) 4 | (:import [javafx.beans.value ChangeListener] 5 | [javafx.collections FXCollections ListChangeListener] 6 | [javafx.event EventHandler] 7 | [javafx.scene.control Button ListView TableView TextField] 8 | [javafx.stage Stage] 9 | [org.tbee.javafx.scene.layout MigPane])) 10 | 11 | 12 | (defmacro without-listener 13 | "Removes the listener defined by k (and expected in the properties of a JavaFX Node) 14 | from the thing reachable via vc and the access-path, then executes the expr and adds 15 | the listener afterwards." 16 | [vc access-path k expr] 17 | `(let [l# (-> ~vc .getProperties (.get ~k))] 18 | (-> ~vc ~@access-path (.removeListener l#)) 19 | ~expr 20 | (-> ~vc ~@access-path (.addListener l#)))) 21 | 22 | 23 | ; ------------------------------------------------------------------------------ 24 | ;; Create setter functions to uniformly update properties in visual components 25 | 26 | (defn- common-setter-fns 27 | [vc] 28 | {:enabled #(.setDisable vc (not %)) 29 | :visible #(.setVisible vc %)}) 30 | 31 | (defn- items-selection-fns 32 | [vc] 33 | (assoc (common-setter-fns vc) 34 | :selection #(without-listener vc [.getSelectionModel .getSelectedIndices] :selection-listener 35 | (-> vc .getSelectionModel 36 | (.selectIndices (or (first %) -1) (int-array (rest %))))) 37 | :items #(without-listener vc [.getSelectionModel .getSelectedIndices] :selection-listener 38 | (.setItems vc (FXCollections/observableArrayList %))))) 39 | 40 | 41 | (defmulti setter-fns 42 | "Returns a map from keyword to 1-arg function for the given visual component. 43 | Each function is used to update a property of the visual component with the 44 | given formatted value." 45 | class) 46 | 47 | 48 | (defmethod setter-fns :default 49 | [vc] 50 | {}) 51 | 52 | 53 | (defmethod setter-fns Button 54 | [vc] 55 | (assoc (common-setter-fns vc) 56 | :text #(.setText vc %))) 57 | 58 | 59 | (defmethod setter-fns ListView 60 | [vc] 61 | (items-selection-fns vc)) 62 | 63 | 64 | (defmethod setter-fns Stage 65 | [vc] 66 | {:title #(.setTitle vc %)}) 67 | 68 | 69 | (defmethod setter-fns TableView 70 | [vc] 71 | (items-selection-fns vc)) 72 | 73 | 74 | (defmethod setter-fns TextField 75 | [vc] 76 | (assoc (common-setter-fns vc) 77 | :text #(without-listener vc [.textProperty] :text-listener 78 | (let [p (-> vc .getCaretPosition)] 79 | (doto vc 80 | (.setText %) 81 | (.positionCaret (min p (count %)))))))) 82 | 83 | 84 | ; ------------------------------------------------------------------------------ 85 | ;; Connect callbacks that write to the events channel of the view 86 | 87 | 88 | (defn- bind-selection-listener! 89 | [vc events-chan] 90 | (let [l (reify ListChangeListener 91 | (onChanged [_ _] 92 | (put! events-chan (make-event (.getId vc) 93 | :selection 94 | :update 95 | (-> vc .getSelectionModel .getSelectedIndices vec)))))] 96 | (-> vc .getSelectionModel .getSelectedIndices (.addListener l)) 97 | (-> vc .getProperties (.put :selection-listener l)))) 98 | 99 | 100 | (defmulti bind! 101 | "Binds listeners to all components of the visual component tree vc. 102 | Each listener puts an event onto the channel." 103 | (fn [vc events-chan] 104 | (class vc))) 105 | 106 | 107 | (defmethod bind! :default 108 | [vc events-chan] 109 | nil) 110 | 111 | 112 | (defmethod bind! Button 113 | [vc events-chan] 114 | (.setOnAction vc 115 | (reify EventHandler 116 | (handle [_ evt] 117 | (put! events-chan (make-event (.getId vc) :action)))))) 118 | 119 | 120 | (defmethod bind! ListView 121 | [vc events-chan] 122 | (bind-selection-listener! vc events-chan)) 123 | 124 | 125 | (defmethod bind! MigPane 126 | [vc events-chan] 127 | (doseq [child (.getChildren vc)] 128 | (bind! child events-chan))) 129 | 130 | 131 | (defmethod bind! Stage 132 | [vc events-chan] 133 | (bind! (-> vc .getScene .getRoot) events-chan) 134 | (let [window-id (-> vc .getScene .getRoot .getProperties (.get :window-id))] 135 | (-> vc (.setOnCloseRequest (reify EventHandler 136 | (handle [_ evt] 137 | (put! events-chan (make-event window-id :close)))))))) 138 | 139 | 140 | (defmethod bind! TableView 141 | [vc events-chan] 142 | (bind-selection-listener! vc events-chan)) 143 | 144 | 145 | (defmethod bind! TextField 146 | [vc events-chan] 147 | (let [l (reify ChangeListener 148 | (changed [_ prop ov nv] 149 | (put! events-chan (make-event (.getId vc) :text :update nv))))] 150 | (-> vc .textProperty (.addListener l)) 151 | (-> vc .getProperties (.put :text-listener l)))) 152 | -------------------------------------------------------------------------------- /src/async_ui/javafx/builder.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.javafx.builder 2 | "JavaFX UI builder" 3 | (:require [async-ui.forml :as f] 4 | [async-ui.core] 5 | [async-ui.javafx.utils :refer [root-window]] 6 | [metam.core :refer [metatype metatype?]]) 7 | (:import [javafx.scene.control Button CheckBox ChoiceBox Label ListView 8 | RadioButton TableView TableColumn TextField 9 | ToggleGroup] 10 | [javafx.scene Scene] 11 | [javafx.stage Stage Modality] 12 | [javafx.util Callback] 13 | [javafx.beans.property ReadOnlyObjectWrapper] 14 | [org.tbee.javafx.scene.layout MigPane])) 15 | 16 | 17 | ;; builder stuff 18 | 19 | (declare build add-component!) 20 | 21 | (defn- make 22 | [clazz spec] 23 | (doto (.newInstance clazz) 24 | (.setId (:name spec)))) 25 | 26 | (defn add-component! 27 | [owner spec] 28 | (let [c (build spec) 29 | lyhint (:lyhint spec)] 30 | (.add owner c lyhint) 31 | c)) 32 | 33 | 34 | (defn- make-panel 35 | [spec] 36 | (let [p (MigPane. (:lygeneral spec) 37 | (:lycolumns spec) 38 | (:lyrows spec))] 39 | (.setId p (:name spec)) 40 | (doseq [spec (:components spec)] 41 | (add-component! p spec)) 42 | p)) 43 | 44 | 45 | (defmulti build metatype 46 | :hierarchy #'f/forml-hierarchy) 47 | 48 | 49 | (defmethod build :default 50 | [spec] 51 | (throw (IllegalArgumentException. 52 | (str "Cannot build type '" 53 | (metatype spec) 54 | "'. Did you implement a build method for this type?")))) 55 | 56 | 57 | (defmethod build ::f/button 58 | [spec] 59 | (doto (make Button spec) 60 | (.setText (:text spec)))) 61 | 62 | 63 | (defmethod build ::f/label 64 | [spec] 65 | (doto (make Label spec) 66 | (.setText (:text spec)))) 67 | 68 | 69 | (defmethod build ::f/listbox 70 | [spec] 71 | (make ListView spec)) 72 | 73 | 74 | (defmethod build ::f/panel 75 | [spec] 76 | (make-panel spec)) 77 | 78 | 79 | (defmethod build ::f/table 80 | [spec] 81 | (let [t (make TableView spec) 82 | cols (.getColumns t)] 83 | (doseq [{:keys [title getter]} (:columns spec)] 84 | (let [tc (TableColumn. title)] 85 | (.setCellValueFactory tc (reify Callback 86 | (call [_ p] 87 | (ReadOnlyObjectWrapper. (-> p .getValue getter))))) 88 | (.add cols tc))) 89 | t)) 90 | 91 | 92 | (defmethod build ::f/textfield 93 | [spec] 94 | (make TextField spec)) 95 | 96 | 97 | (defn- make-stage 98 | "Returns either the root stage if it wasn't already initialized with a scene, 99 | or a new stage that is owned by the root stage, or an explicitly specified 100 | owner." 101 | [spec] 102 | (let [root-stage (root-window)] 103 | (if (-> root-stage .getScene) 104 | (doto (Stage.) 105 | (.initOwner (if-let [owner (some-> async-ui.core/views 106 | deref 107 | (get (:owner spec)) 108 | :vc)] 109 | owner 110 | root-stage)) 111 | (.initModality (case (:modality spec) 112 | :window Modality/WINDOW_MODAL 113 | :application Modality/APPLICATION_MODAL 114 | Modality/NONE))) 115 | root-stage))) 116 | 117 | 118 | (defmethod build ::f/window 119 | [spec] 120 | (let [root (build (:content spec)) 121 | scene (Scene. root)] 122 | (-> root .getProperties (.put :window-id (:name spec))) 123 | (doto (make-stage spec) 124 | (.setScene scene) 125 | (.show) 126 | (.sizeToScene) 127 | (.setTitle (:title spec))))) 128 | 129 | -------------------------------------------------------------------------------- /src/async_ui/javafx/tk.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.javafx.tk 2 | (:require [async-ui.core :as v] 3 | [async-ui.javafx.utils :refer [launch-if-necessary]] 4 | [async-ui.javafx.builder :refer [build]] 5 | [async-ui.javafx.binding :as b]) 6 | (:import [async_ui.core Toolkit] 7 | [javafx.application Platform] 8 | [javafx.scene.control Tooltip] 9 | [javafx.stage Stage] 10 | [org.tbee.javafx.scene.layout MigPane])) 11 | 12 | 13 | (defrecord JfxToolkit [] 14 | Toolkit 15 | (run-now [tk f] 16 | (launch-if-necessary) 17 | (let [result (promise)] 18 | (Platform/runLater #(deliver result 19 | (try (f) 20 | (catch Exception e (do (.printStackTrace e) e))))) 21 | @result)) 22 | (show-view! [tk view] 23 | (some-> view :vc .show)) 24 | (hide-view! [tk view] 25 | (some-> view :vc .close)) 26 | (build-vc-tree [tk view] 27 | (v/hide-view! tk view) 28 | (assoc view :vc (build (:spec view)))) 29 | (bind-vc-tree! [tk view] 30 | (b/bind! (:vc view) (:events view)) 31 | (assoc view 32 | :setter-fns (v/setter-map tk (:vc view) b/setter-fns (:mapping view)))) 33 | (vc-name [tk vc] 34 | (if (instance? Stage vc) 35 | (-> vc .getScene .getRoot .getProperties (.get :window-id)) 36 | (.getId vc))) 37 | (vc-children [tk vc] 38 | (condp instance? vc 39 | MigPane (or (.getChildren vc) []) 40 | Stage (-> vc .getScene .getRoot vector) 41 | [])) 42 | (set-vc-error! [tk vc msgs] 43 | (if (seq msgs) 44 | (.setTooltip vc (Tooltip. (apply str msgs))) 45 | (.setTooltip vc nil)))) 46 | 47 | 48 | (defn make-toolkit 49 | [] 50 | (JfxToolkit.)) 51 | -------------------------------------------------------------------------------- /src/async_ui/javafx/utils.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.javafx.utils 2 | (:require [async-ui.javafx.application :as app] 3 | [environ.core :refer [env]]) 4 | (:import [javafx.application Application Platform])) 5 | 6 | 7 | (defonce ^:private app-starter-thread (atom nil)) 8 | (defonce ^:private force-toolkit-init 9 | (do 10 | ;; Keep JavaFX running even if no window is visible 11 | (Platform/setImplicitExit false) 12 | ;; This is a hack to finally call 13 | ;; com.sun.javafx.application.PlatformImpl.startup() 14 | ;; which starts the JavaFX application thread 15 | ;; this is needed because static class initializers in 16 | ;; JavaFX classes rely on calls that expect to be run on 17 | ;; the app thread, sigh 18 | (javafx.embed.swing.JFXPanel.))) 19 | 20 | (compile 'async-ui.javafx.application) 21 | 22 | 23 | (defn launch-if-necessary 24 | [] 25 | (when-not @app-starter-thread 26 | (reset! app-starter-thread (Thread. #(javafx.application.Application/launch 27 | async_ui.javafx.application 28 | (into-array String [])))) 29 | (.start @app-starter-thread)) 30 | @app/root-stage) 31 | 32 | 33 | (defn root-window 34 | [] 35 | (launch-if-necessary)) 36 | 37 | 38 | ;; Ensure that JavaFX is shutdown when in uberjar compilation. 39 | ;; However, it still takes about 1 minute before the JVM actually terminates. 40 | 41 | ;; To enable this add the entry :env {:javafx-exit true} in :uberjar profile. 42 | ;; Please note that the values are "transmitted" to the compile process 43 | ;; via a .lein-env file. 44 | ;; Thus, if you do an uberjar and then execute the resulting jar from the 45 | ;; project dir the JavaFX platform exit will happen again. 46 | ;; lein run or repl are not affected because they overwrite .lein-env 47 | 48 | (when (env :javafx-exit) 49 | (future (println "Process" (-> (java.lang.management.ManagementFactory/getRuntimeMXBean) .getName)) 50 | (println "Waiting 5 secs before exiting JavaFX platform") 51 | (Thread/sleep 5000) 52 | (println "Exiting JavaFX platform") 53 | (Platform/setImplicitExit true) 54 | (Platform/exit))) 55 | -------------------------------------------------------------------------------- /src/async_ui/main.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.main 2 | (:require [async-ui.ex-master-detail :as ex]) 3 | (:gen-class)) 4 | 5 | (defn -main 6 | [& args] 7 | (ex/start!) 8 | ;; make sure the JVM does not terminate before window is shown 9 | (Thread/sleep 500)) 10 | -------------------------------------------------------------------------------- /src/async_ui/swing/binding.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.swing.binding 2 | (:require [clojure.core.async :refer [put!]] 3 | [async-ui.core :refer [make-event]]) 4 | (:import [javax.swing JButton JComponent JFrame JLabel JList JPanel JScrollPane JTable JTextField] 5 | [javax.swing.text JTextComponent] 6 | [java.awt Container] 7 | [java.awt.event ActionListener WindowListener] 8 | [javax.swing.event DocumentListener ListSelectionListener])) 9 | 10 | 11 | ; ------------------------------------------------------------------------------ 12 | ;; Create setter functions to uniformly update properties in visual components 13 | 14 | 15 | (defn- common-setter-fns 16 | [vc] 17 | {:enabled #(.setEnabled vc (if (nil? %) false %)) 18 | :visible #(.setVisible vc (if (nil? %) false %))}) 19 | 20 | 21 | (defn- set-selection! 22 | [vc index] 23 | (let [m (.getSelectionModel vc) 24 | l (.getClientProperty vc :listener)] 25 | (doto m 26 | (.removeListSelectionListener l) 27 | (.setSelectionInterval index index) 28 | (.addListSelectionListener l)))) 29 | 30 | 31 | (defmulti setter-fns 32 | "Returns a map from keyword to 1-arg function for the given visual component. 33 | Each function is used to update a property of the visual component with the 34 | given formatted value." 35 | class) 36 | 37 | 38 | (defmethod setter-fns :default 39 | [vc] 40 | {}) 41 | 42 | 43 | (defmethod setter-fns JButton 44 | [vc] 45 | (assoc (common-setter-fns vc) 46 | :text #(.setText vc %))) 47 | 48 | 49 | (defmethod setter-fns JFrame 50 | [vc] 51 | (assoc (common-setter-fns vc) 52 | :title #(.setTitle vc %))) 53 | 54 | 55 | (defmethod setter-fns JLabel 56 | [vc] 57 | (assoc (common-setter-fns vc) 58 | :text #(.setText vc %))) 59 | 60 | 61 | (defmethod setter-fns JList 62 | [vc] 63 | (assoc (common-setter-fns vc) 64 | :selection #(set-selection! vc (or (first %) 0)) 65 | :items #(do (.putClientProperty vc :data %) 66 | (let [m (.getModel vc)] 67 | (.fireContentsChanged m m 0 (count %)))))) 68 | 69 | 70 | (defmethod setter-fns JPanel 71 | [vc] 72 | (common-setter-fns vc)) 73 | 74 | 75 | (defmethod setter-fns JTable 76 | [vc] 77 | (assoc (common-setter-fns vc) 78 | :selection #(set-selection! vc (or (first %) 0)) 79 | :items #(do (.putClientProperty vc :data %) 80 | (.repaint vc)))) 81 | 82 | 83 | (defn- set-text! 84 | "Silently sets the text property of a text component, 85 | if the textfield does not have the focus." 86 | [vc text] 87 | (if-not (.hasFocus vc) 88 | (let [doc (-> vc .getDocument) 89 | l (.getClientProperty vc :listener) 90 | p (.getCaretPosition vc)] 91 | (.removeDocumentListener doc l) 92 | (.setText vc text) 93 | (.addDocumentListener doc l) 94 | (.setCaretPosition vc (min (count text) p))))) 95 | 96 | 97 | (defmethod setter-fns JTextComponent 98 | [vc] 99 | (assoc (common-setter-fns vc) 100 | :editable #(.setEditable vc %) 101 | :text (partial set-text! vc))) 102 | 103 | 104 | 105 | ; ------------------------------------------------------------------------------ 106 | ;; Connect callbacks that write to the events channel of the view 107 | 108 | 109 | (defn- bind-selection-listener! 110 | [vc events-chan] 111 | (let [sel-model (.getSelectionModel vc) 112 | l (reify ListSelectionListener 113 | (valueChanged [_ evt] 114 | (when-not (.getValueIsAdjusting evt) 115 | (let [sel (vec (range (.getMinSelectionIndex sel-model) 116 | (inc (.getMaxSelectionIndex sel-model)))) 117 | sel (if (= [-1] sel) [] sel)] 118 | (put! events-chan (make-event (.getName vc) :selection :update sel))))))] 119 | (.addListSelectionListener sel-model l) 120 | (.putClientProperty vc :listener l))) 121 | 122 | 123 | (defmulti bind! 124 | "Binds listeners to all components of the visual component tree vc. 125 | Each listener puts an event onto the channel." 126 | (fn [vc events-chan] 127 | (class vc))) 128 | 129 | 130 | (defmethod bind! :default 131 | [vc events-chan] 132 | nil) 133 | 134 | 135 | (defmethod bind! JButton 136 | [vc events-chan] 137 | (.addActionListener vc (reify ActionListener 138 | (actionPerformed [_ _] 139 | (put! events-chan (make-event (.getName vc) :action)))))) 140 | 141 | 142 | (defmethod bind! JFrame 143 | [vc events-chan] 144 | (-> vc (.addWindowListener 145 | (reify WindowListener 146 | (windowOpened [_ _]) 147 | (windowClosing [_ _] 148 | (put! events-chan (make-event (.getName vc) :close))) 149 | (windowActivated [_ _]) 150 | (windowDeactivated [_ _]) 151 | (windowClosed [_ _])))) 152 | (bind! (.getContentPane vc) events-chan)) 153 | 154 | 155 | (defmethod bind! JList 156 | [vc events-chan] 157 | (bind-selection-listener! vc events-chan)) 158 | 159 | 160 | (defmethod bind! JPanel 161 | [vc events-chan] 162 | (doseq [child-vc (.getComponents vc)] 163 | (bind! child-vc events-chan))) 164 | 165 | 166 | (defn- text-from-event 167 | [evt] 168 | (let [doc (.getDocument evt)] 169 | (.getText doc 0 (.getLength doc)))) 170 | 171 | 172 | (defmethod bind! JScrollPane 173 | [vc events-chan] 174 | (bind! (-> vc .getViewport .getView) events-chan)) 175 | 176 | 177 | (defmethod bind! JTable 178 | [vc events-chan] 179 | (bind-selection-listener! vc events-chan)) 180 | 181 | 182 | (defmethod bind! JTextComponent 183 | [vc events-chan] 184 | (let [l (reify DocumentListener 185 | (insertUpdate [_ evt] 186 | (put! events-chan (make-event (.getName vc) :text :update (text-from-event evt)))) 187 | (removeUpdate [_ evt] 188 | (put! events-chan (make-event (.getName vc) :text :update (text-from-event evt)))) 189 | (changedUpdate [_ evt] 190 | (put! events-chan (make-event (.getName vc) :text :update (text-from-event evt)))))] 191 | (-> vc 192 | .getDocument 193 | (.addDocumentListener l)) 194 | (.putClientProperty vc :listener l))) 195 | 196 | -------------------------------------------------------------------------------- /src/async_ui/swing/builder.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.swing.builder 2 | "Swing UI builder" 3 | (:require [async-ui.forml :as f] 4 | [metam.core :refer [metatype metatype?]]) 5 | (:import [javax.swing AbstractListModel 6 | JButton JFrame JLabel JList JPanel JTable JScrollPane JTextField 7 | ListSelectionModel] 8 | [javax.swing.table DefaultTableCellRenderer DefaultTableColumnModel 9 | TableColumn TableCellRenderer TableModel] 10 | [javax.swing DefaultListModel] 11 | [java.awt.event ActionListener] 12 | [net.miginfocom.swing MigLayout])) 13 | 14 | 15 | (defn- make 16 | [clazz spec] 17 | (doto (.newInstance clazz) 18 | (.setName (:name spec)))) 19 | 20 | 21 | (defmulti build metatype 22 | :hierarchy #'f/forml-hierarchy) 23 | 24 | 25 | (defmethod build :default 26 | [spec] 27 | (throw (IllegalArgumentException. 28 | (str "Cannot build type '" 29 | (metatype spec) 30 | "'. Did you implement a build method for this type?")))) 31 | 32 | 33 | (defmethod build ::f/button 34 | [spec] 35 | (doto (make JButton spec) 36 | (.setText (:text spec)))) 37 | 38 | 39 | (defmethod build ::f/label 40 | [spec] 41 | (doto (make JLabel spec) 42 | (.setText (:text spec)))) 43 | 44 | 45 | (defmethod build ::f/listbox 46 | [spec] 47 | (let [l (make JList spec) 48 | sp (JScrollPane. l)] 49 | (doto l 50 | (.setModel (proxy [AbstractListModel] [] 51 | (getSize [] 52 | (-> l (.getClientProperty :data) count)) 53 | (getElementAt [row] 54 | (-> l (.getClientProperty :data) (nth row)))))) 55 | sp)) 56 | 57 | 58 | (defmethod build ::f/panel 59 | [spec] 60 | (let [p (doto (make JPanel spec) 61 | (.setLayout (MigLayout. (:lygeneral spec) (:lycols spec) (:lyrows spec))))] 62 | (doseq [child (:components spec)] 63 | (let [vc (build child)] 64 | (.add p vc (:lyhint child)))) 65 | p)) 66 | 67 | 68 | (declare table-column-model) 69 | 70 | (defmethod build ::f/table 71 | [spec] 72 | (let [t (make JTable spec) 73 | sp (JScrollPane. t) 74 | cols (:columns spec)] 75 | (doto t 76 | (.setColumnModel (table-column-model (-> spec :columns))) 77 | (.setAutoCreateColumnsFromModel false) 78 | (.setSelectionMode ListSelectionModel/SINGLE_SELECTION) 79 | (.setModel (reify TableModel 80 | (getColumnClass [_ column] 81 | java.lang.String) 82 | (getColumnName [_ column] 83 | (get-in cols [column :title])) 84 | (getColumnCount [_] 85 | (count cols)) 86 | (getRowCount [_] 87 | (count (.getClientProperty t :data))) 88 | (getValueAt [_ row column] 89 | (let [getter-fn (get-in cols [column :getter])] 90 | (-> (.getClientProperty t :data) 91 | (nth row) 92 | (getter-fn)))) 93 | (isCellEditable [_ row column] 94 | false) 95 | (setValueAt [_ row column v] 96 | nil) 97 | (addTableModelListener [_ l]) 98 | (removeTableModelListener [_ l])))) 99 | sp)) 100 | 101 | 102 | (defmethod build ::f/textfield 103 | [spec] 104 | (make JTextField spec)) 105 | 106 | 107 | (defmethod build ::f/window 108 | [spec] 109 | (doto (make JFrame spec) 110 | (.setTitle (:title spec)) 111 | (.setContentPane (-> spec :content build)) 112 | (.setVisible true) 113 | (.setDefaultCloseOperation JFrame/DISPOSE_ON_CLOSE) 114 | (.pack))) 115 | 116 | 117 | 118 | ; ------------------------------------------------------------------------------ 119 | ;; Setup table 120 | 121 | 122 | (defn- table-column-model 123 | [column-specs] 124 | (let [tcm (DefaultTableColumnModel.)] 125 | (doseq [[i c] (map vector (range) column-specs)] 126 | (.addColumn tcm 127 | (doto (TableColumn.) 128 | (.setIdentifier c) 129 | (.setModelIndex i) 130 | (.setHeaderValue (-> c :title))))) 131 | tcm)) 132 | 133 | 134 | -------------------------------------------------------------------------------- /src/async_ui/swing/tk.clj: -------------------------------------------------------------------------------- 1 | (ns async-ui.swing.tk 2 | (:require [async-ui.core :as v] 3 | [async-ui.swing.binding :as b] 4 | [async-ui.swing.builder :refer [build]]) 5 | (:import [async_ui.core Toolkit] 6 | [java.awt Color Container] 7 | [javax.swing JComponent JFrame JPanel JScrollPane SwingUtilities])) 8 | 9 | 10 | (defrecord SwingToolkit [] 11 | Toolkit 12 | (run-now [tk f] 13 | (SwingUtilities/invokeAndWait f)) 14 | (show-view! [tk view] 15 | (some-> view :vc (.setVisible true))) 16 | (hide-view! [tk view] 17 | (some-> view :vc (.setVisible false))) 18 | (build-vc-tree [tk view] 19 | (v/hide-view! tk view) 20 | (assoc view :vc (build (:spec view)))) 21 | (bind-vc-tree! [tk view] 22 | (b/bind! (:vc view) (:events view)) 23 | (assoc view 24 | :setter-fns (v/setter-map tk (:vc view) b/setter-fns (:mapping view)))) 25 | (vc-children [tk vc] 26 | (map #(if (instance? JScrollPane %) 27 | (-> % .getViewport .getView) 28 | %) 29 | (condp = (class vc) 30 | JFrame [(.getContentPane vc)] 31 | JPanel (.getComponents vc) 32 | []))) 33 | (vc-name [tk vc] 34 | (.getName vc)) 35 | (set-vc-error! [tk vc msgs] 36 | (when (instance? JComponent vc) 37 | (if (seq msgs) 38 | (doto vc 39 | (if-not (.getClientProperty vc :background-color) 40 | (.putClientProperty vc :background-color (.getBackground vc))) 41 | (.setBackground Color/RED) 42 | (.setToolTipText (apply str msgs))) 43 | (if-let [bgc (.getClientProperty vc :background-color)] 44 | (doto vc 45 | (.setBackground bgc) 46 | (.setToolTipText nil))))))) 47 | 48 | (defn make-toolkit 49 | [] 50 | (SwingToolkit.)) 51 | --------------------------------------------------------------------------------