Implemented action handling in Buttons and Menus

build.boot

@@ -26,7 +26,8 @@
       :scm {:url "https://bitbucket.com/zilti/clojurefx"}
       :license {"name" "GNU Lesser General Public License 3.0"
                 "url" "http://www.gnu.org/licenses/lgpl-3.0.txt"}}
- midje {:test-paths #{"test"}}
+ midje {:test-paths #{"test"}
+        :sources #{"src" "test"}}
  typed {:namespaces #{'clojurefx.clojurefx 'clojurefx.protocols 'clojurefx.scripting}}
  repl {:server true})
 
@@ -35,8 +36,6 @@
   (task-options!
    midje {:autotest true})
   
-  (set-env! :resource-paths #{"src" "test"})
-  
   (comp (repl)
         (midje)
         (watch)

src/clojurefx/clojurefx.clj

@@ -5,22 +5,26 @@
             [taoensso.timbre :as timbre]
             [clojure.java.io :as io]
             [clojure.zip :as zip]
-            [clojurefx.protocols :refer :all]
+            [clojurefx.protocols :as p]
             [clojure.java.io :refer :all]))
 
 (defonce force-toolkit-init (javafx.embed.swing.JFXPanel.))
 
 ;; ## Threading helpers
 
-(defn run-later*"
+(ann run-later* [(Fn [-> Any]) -> nil])
-Simple wrapper for Platform/runLater. You should use run-later.
+  (defn run-later*"
+  Simple wrapper for Platform/runLater. You should use run-later.
 " [f]
-(javafx.application.Platform/runLater f))
+(tc-ignore (assert (instance? Runnable f))
+           (javafx.application.Platform/runLater f))
+nil)
 
 (defmacro run-later [& body]
   `(run-later* (fn [] ~@body)))
 
-  (defn run-now*"
+(ann run-now* (All [x] [[-> x] -> x]))
+  (defn run-now* "
   A modification of run-later waiting for the running method to return. You should use run-now.
 " [f]
 (if (javafx.application.Platform/isFxApplicationThread)
@@ -39,34 +43,30 @@ Simple wrapper for Platform/runLater. You should use run-later.
 
 (import (javafx.scene.control Labeled Label TextField TextArea CheckBox ComboBox Menu MenuItem MenuBar
                               MenuButton ContextMenu ToolBar SplitPane ScrollPane Accordion
-                              TitledPane TabPane Tab TableColumnBase Labeled)
+                              TitledPane TabPane Tab TableColumnBase Labeled ButtonBase)
         (javafx.scene Node Scene Parent)
         (javafx.scene.layout Pane VBox)
         (javafx.stage Stage)
         (javafx.collections FXCollections ObservableList)
         (javafx.css Styleable)
+        (javafx.event Event ActionEvent EventTarget)
         (java.util Collection))
 
-;; TODO Use pred-substitute for tc-assert?
 (defn tc-assert [clazz :- Class value :- Any & [message :- String]]
   (try (assert (instance? clazz value))
        (catch AssertionError e (tc-ignore (error (if message message "") e)
                                           (error "Expected:" clazz "Actual:" (type value))
                                           (throw e)))))
 
-(ann pred-substitute [Class -> (Fn [Any -> Boolean])])
+(defn pred-protocol [proto :- (HMap :mandatory {:impls (Map Keyword Class)}) check :- Any] :- Boolean
-(defn pred-substitute [clazz]
-  (clojure.core.typed/pred* (quote clazz) 'clojurefx.clojurefx
-                            (fn [arg] (boolean (instance? clazz arg)))))
-
-(defn pred-protocol [proto check]
   (let [impls (keys (proto :impls))
         check (type check)]
     (reduce #(or %1 (isa? check %2)) false impls)))
 
 ;;## Shadows
 
-(extend-protocol FXMeta
+(tc-ignore
+ (extend-protocol p/FXMeta
    clojure.lang.IObj
    (meta [this] (clojure.core/meta this))
    (with-meta [this metadata] (clojure.core/with-meta this metadata))
@@ -75,12 +75,12 @@ Simple wrapper for Platform/runLater. You should use run-later.
    (with-meta [this metadata] (.setUserData ^Node this metadata) this)
    MenuItem
    (meta [this] (.getUserData ^MenuItem this))
-  (with-meta [this metadata] (.setUserData ^MenuItem this metadata) this))
+   (with-meta [this metadata] (.setUserData ^MenuItem this metadata) this)))
 
 ;;## Standard
 
 (tc-ignore
- (extend-protocol FXValue
+ (extend-protocol p/FXValue
    Labeled
    (get-value [this] (.getText ^Label this))
    (set-value! [this value] (tc-assert String value) (.setText ^Label this ^String value) this)
@@ -112,13 +112,13 @@ Simple wrapper for Platform/runLater. You should use run-later.
    (set-value! [this value] (tc-assert String value) (.setText ^MenuItem this ^String value) this)))
 
 (tc-ignore
- (extend-protocol FXId
+ (extend-protocol p/FXId
    Styleable
    (get-id [this] (.getId ^Styleable this))
    (set-id! [this id] (tc-assert String id) (.setId ^Styleable this ^String id) this)))
 
 (tc-ignore
- (extend-protocol FXParent
+ (extend-protocol p/FXParent
    Pane
    (get-subnodes [this] (.getChildren ^Pane this))
    (set-subnodes! [this nodes] (.setAll ^ObservableList (.getChildren ^Pane this) ^Collection nodes) this)
@@ -148,7 +148,7 @@ Simple wrapper for Platform/runLater. You should use run-later.
    (set-subnodes! [this nodes] (.setAll ^ObservableList (.getPanes ^Accordion this) ^Collection nodes) this)))
 
 (tc-ignore
- (extend-protocol FXContainer
+ (extend-protocol p/FXContainer
    Tab
    (get-content [this] (.getContent ^Tab this))
    (set-content! [this node] (.setContent ^Tab this ^Node node) this)
@@ -160,7 +160,7 @@ Simple wrapper for Platform/runLater. You should use run-later.
    (set-content! [this node] (.setContent ^ScrollPane this ^Node node) this)))
 
 (tc-ignore
- (extend-protocol FXGraphic
+ (extend-protocol p/FXGraphic
    Labeled
    (get-graphic [this] (.getGraphic ^Labeled this))
    (set-graphic! [this graphic] (.setGraphic ^Labeled this ^Node graphic))
@@ -168,60 +168,99 @@ Simple wrapper for Platform/runLater. You should use run-later.
    (get-graphic [this] (.getGraphic ^Menu this))
    (set-graphic! [this graphic] (.setGraphic ^Menu this ^Node graphic))))
 
-(extend-protocol FXStyleSetter
+(tc-ignore
+ (extend-protocol p/FXStyleSetter
    Node
    (set-style! [this style] (.setStyle ^Node this ^String style) this)
    MenuItem
-  (set-style! [this style] (.setStyle ^MenuItem this ^String style) this))
+   (set-style! [this style] (.setStyle ^MenuItem this ^String style) this)))
 
-(extend-type Styleable
+(tc-ignore
-  FXStyleable
+ (extend-type Styleable
+   p/FXStyleable
    (get-css-meta [this] (.getCssMetaData ^Styleable this))
    (get-pseudo-class-styles [this] (.getPseudoClassStyles ^Styleable this))
    (get-style [this] (.getStyle ^Styleable this))
    (get-style-classes [this] (.getStyleClass ^Styleable this))
    (set-style-classes! [this classes] (.setAll ^ObservableList (.getStyleClass ^Styleable this) classes) this)
    (get-styleable-parent [this] (.getStyleableParent ^Styleable this))
-  (get-type-selector [this] (.getTypeSelector ^Styleable this)))
+   (get-type-selector [this] (.getTypeSelector ^Styleable this))))
+
+(declare bind-event)
+(tc-ignore
+ (extend-protocol p/FXOnAction
+   ButtonBase
+   (set-action! [this action] (.setOnAction ^ButtonBase this (bind-event action)) this)
+   (fire! [this] (.fire this))
+   MenuItem
+   (set-action! [this action] (.setOnAction ^ButtonBase this (bind-event action)) this)
+   (fire! [this] (.fire this))))
 
 ;;## Special Types
 
-(extend-type Stage
+;;### javafx.event
-  FXStage
+
+(tc-ignore
+ (extend-type Event
+   p/FXEvent
+   (source [this] (.getSource ^Event this))
+   (consume! [this] (.consume ^Event this) this)
+   (copy [this new-src new-target] (.copy ^Event this new-src new-target))
+   (event-type [this] (.getEventType this))
+   (target [this] (.getTarget this))
+   (consumed? [this] (.isConsumed this))))
+
+;;### javafx.stage
+
+(tc-ignore
+ (extend-type Stage
+   p/FXStage
    (get-title [this] (.getTitle ^Stage this))
    (set-title! [this title] (.setTitle ^Stage this ^String title))
    (get-scene [this] (.getScene ^Stage this))
-  (set-scene! [this scene] (.setScene ^Stage this ^Scene scene)))
+   (set-scene! [this scene] (.setScene ^Stage this ^Scene scene))))
 
-(extend-type Scene
+;;### javafx.scene
-  FXScene
+
+(tc-ignore
+ (extend-type Scene
+   p/FXScene
    (get-root [this] (.getRoot ^Scene this))
-  (set-root! [this root] (.setRoot ^Scene this ^Parent root) this))
+   (set-root! [this root] (.setRoot ^Scene this ^Parent root) this)))
+
+;;## Event handling helper
+(tc-ignore
+ (defn bind-event
+   [handler :- (All [[A :variance :covariant :< Event]] (Fn [A -> Any]))] :- javafx.event.EventHandler
+   (reify javafx.event.EventHandler
+     (handle [_ event] (handler event)))))
 
 ;;## IdMapper
 (defn fxzipper [root]
-  (zip/zipper (fn branch? [node]
+  (zip/zipper (fn branch? [node :- Any] :- Boolean
-                (or (pred-protocol FXParent node) (pred-protocol FXContainer node)))
+                (or (pred-protocol p/FXParent node) (pred-protocol p/FXContainer node)))
-              (fn children [node]
+              (fn children [node :- (U p/FXParent p/FXContainer)] :- java.util.List
-                (if (pred-protocol FXParent node)
+                (if (pred-protocol p/FXParent node)
-                  (into [] (get-subnodes node))
+                  (into [] (p/get-subnodes node))
-                  [(get-content node)]))
+                  [(p/get-content node)]))
-              (fn make-node [node children]
+              (fn make-node [node :- (U p/FXParent p/FXContainer) children :- Any] :- (U p/FXParent p/FXContainer)
-                (if (pred-protocol FXParent node)
+                (if (pred-protocol p/FXParent node)
-                  (set-subnodes! node children)
+                  (p/set-subnodes! node children)
-                  (set-content! node children)))
+                  (p/set-content! node children)))
               root))
 
-(defn get-node-by-id [graph id]
+(tc-ignore
+ (defn get-node-by-id [graph id]
    (loop [zipper (fxzipper graph)]
      (cond (zip/end? zipper) nil
-          (= (get-id (zip/node zipper)) (name id)) (zip/node zipper)
+           (= (p/get-id (zip/node zipper)) (name id)) (zip/node zipper)
-          :else (recur (zip/next zipper)))))
+           :else (recur (zip/next zipper))))))
 
-(defn get-id-map [graph]
+(tc-ignore
+ (defn get-id-map [graph]
    (loop [zipper (fxzipper graph)
           ids {}]
      (if (zip/end? zipper)
        ids
        (recur (zip/next zipper)
-             (assoc ids (keyword (get-id (zip/node zipper))) (zip/node zipper))))))
+              (assoc ids (keyword (p/get-id (zip/node zipper))) (zip/node zipper)))))))

src/clojurefx/factory.clj

@@ -22,6 +22,7 @@
 (def getter first)
 (def setter second)
 
+(ann translation-map (Atom1 (Map Keyword (Vec clojure.lang.Var))))
 (def translation-map
   (atom {;;; FXValue
          :text (with-meta [#'get-value #'set-value!] {:argument String :parent FXValue})

src/clojurefx/protocols.clj

@@ -27,7 +27,7 @@
 (defalias FXElement (U FXValue FXId))
 
 (defprotocol [[A :variance :covariant]
-              [B :variance :covariant]]
+              [B :variance :covariant :< Seqable]]
   FXParent
   "The ClojureFX extension to javafx.scene.Parent."
   (get-subnodes [this :- A] :- B)
@@ -63,8 +63,26 @@
 
 (defalias FXStyled (U FXStyleable FXStyleSetter))
 
+(defprotocol [[A :variance :covariant]]
+  FXOnAction
+  (set-action! [this :- A action :- [javafx.event.EventHandler -> Any]] :- A)
+  (fire! [this :- A] :- nil))
+
 ;;## Special Types
 
+;;### javafx.event
+
+(defprotocol [[A :variance :covariant :< javafx.event.Event]]
+  FXEvent
+  (source [this :- A] :- Any)
+  (consume! [this :- A] :- A)
+  (copy [this :- A newSource :- Object newTarget :- javafx.event.EventTarget] :- A)
+  (event-type [this :- A] :- javafx.event.EventType)
+  (target [this :- A] :- javafx.event.EventTarget)
+  (consumed? [this :- A] :- Boolean))
+
+;;### javafx.stage
+
 (defprotocol [[A :variance :covariant :< javafx.stage.Stage]
               [B :variance :covariant :< javafx.scene.Scene]]
   FXStage
@@ -73,6 +91,8 @@
   (get-scene [this :- A] :- B)
   (set-scene! [this :- A scene :- B] :- A))
 
+;;### javafx.scene
+
 (defprotocol [[A :variance :covariant :< javafx.scene.Scene]
               [B :variance :covariant :< javafx.scene.Parent]]
   FXScene

test/clojurefx/clojurefx_test.clj

@@ -10,6 +10,16 @@
 
 ;;## Element testing
 
+;;## Event testing
+(def button (new Button))
+(def fired? (atom false))
+(facts "Events"
+       (fact "Adding an event handler"
+             (set-action! button (fn [event] (reset! fired? true))) => button)
+       (fact "Firing the event and checking the result"
+             (do (fire! button)
+                 @fired?) => true))
+
 ;;## IdMapper
 (def example-graph
   (factory/compile