Restructured code. Improved 'compile'. Added more wrappers.

README.md

@@ -9,11 +9,11 @@ This is in a very early state, so there isn't much yet, except one thing.
 ### Declarative UI programming
 
 ```clojure
-(compile [:VBox {:id "TopLevelVBox"
+(compile [VBox {:id "TopLevelVBox"
-                 :children [:Label {:text "Hi!"}
+                :children [Label {:text "Hi!"}
-                            :Label {:text "I'm ClojureFX!"}
+                           Label {:text "I'm ClojureFX!"}
-                            :HBox {:id "HorizontalBox"
+                           HBox {:id "HorizontalBox"
-                                   :children [:Button {:text "Alright."}]}]}])
+                                 :children [Button {:text "Alright."}]}]}])
 ```
 
 ## TODO

build.boot

@@ -3,6 +3,7 @@
           :dependencies '[[org.clojure/clojure "1.7.0-alpha4"]
                           [com.taoensso/timbre "3.3.1" :exclusions [com.taoensso/carmine]]
                           [org.clojure/core.typed "0.2.77"]
+                          [clojure-jsr-223 "0.1.0"]
 
                           [boot-deps "0.1.2" :scope "test"]
                           [midje "1.6.3" :scope "test"]
@@ -12,14 +13,14 @@
 (require '[zilti.boot-midje :refer [midje]]
          '[zilti.boot-typed :refer [typed]])
 
-(def +version+ "0.0.1-SNAPSHOT")
+(def +version+ "0.0.5-SNAPSHOT")
 
 (task-options!
- pom {:project 'ClojureFX
+ pom {:project 'clojurefx
       :version +version+
       :description "A Clojure JavaFX wrapper."
-      :url "https://bitbucket.com/zilti/ClojureFX"
+      :url "https://bitbucket.com/zilti/clojurefx"
-      :scm {:url "https://bitbucket.com/zilti/ClojureFX"}
+      :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"}

src/clojurefx/clojurefx.clj

@@ -4,17 +4,46 @@
             [clojure.core.typed.unsafe :refer [ignore-with-unchecked-cast]]
             [taoensso.timbre :as timbre]
             [clojure.java.io :as io]
-            [clojurefx.protocols :refer :all]))
+            [clojurefx.protocols :refer :all]
+            [clojure.java.io :refer :all]))
 
 (defonce force-toolkit-init (javafx.embed.swing.JFXPanel.))
+
+;; ## Threading helpers
+
+(defn run-later*"
+Simple wrapper for Platform/runLater. You should use run-later.
+" [f]
+(javafx.application.Platform/runLater f))
+
+(defmacro run-later [& body]
+  `(run-later* (fn [] ~@body)))
+
+(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)
+  (apply f [])
+  (let [result (promise)]
+    (run-later
+     (deliver result (try (f) (catch Throwable e e))))
+    @result)))
+
+(defmacro run-now "
+Runs the code on the FX application thread and waits until the return value is delivered.
+" [& body]
+`(run-now* (fn [] ~@body)))
+
 (tc-ignore (timbre/refer-timbre))
 
 (import (javafx.scene.control Label TextField TextArea CheckBox ComboBox Menu MenuItem MenuBar
                               MenuButton ContextMenu ToolBar SplitPane ScrollPane Accordion
                               TitledPane TabPane Tab TableColumnBase Labeled)
-        (javafx.scene Node)
+        (javafx.scene Node Scene Parent)
         (javafx.scene.layout Pane VBox)
+        (javafx.stage Stage)
         (javafx.collections FXCollections ObservableList)
+        (javafx.css Styleable)
         (java.util Collection))
 
 ;; TODO This belongs elsewhere.
@@ -68,18 +97,9 @@
 
 (tc-ignore
  (extend-protocol FXId
-   Node
+   Styleable
-   (get-id [this] (.getId ^Node this))
+   (get-id [this] (.getId ^Styleable this))
-   (set-id! [this id] (tc-assert String id) (.setId ^Node this ^String id) this)
+   (set-id! [this id] (tc-assert String id) (.setId ^Styleable this ^String id) this)))
-   Tab
-   (get-id [this] (.getId ^Tab this))
-   (set-id! [this id] (tc-assert String id) (.setId ^Tab this ^String id) this)
-   TableColumnBase
-   (get-id [this] (.getId ^TableColumnBase this))
-   (set-id! [this id] (tc-assert String id) (.setId ^TableColumnBase this ^String id) this)
-   MenuItem
-   (get-id [this] (.getId ^MenuItem this))
-   (set-id! [this id] (tc-assert String id) (.setId ^MenuItem this ^String id) this)))
 
 (tc-ignore
  (extend-protocol FXParent
@@ -132,58 +152,39 @@
    (get-graphic [this] (.getGraphic ^Menu this))
    (set-graphic! [this graphic] (.setGraphic ^Menu this ^Node graphic))))
 
+(tc-ignore
+ (extend-protocol clojure.lang.IObj
+   Node
+   (meta [this] (.getUserData ^Node this))
+   (withMeta [this metadata] (.setUserData ^Node this metadata) this)
+   MenuItem
+   (meta [this] (.getUserData ^MenuItem this))
+   (withMeta [this metadata] (.setUserData ^MenuItem this metadata) this)))
 
-;; TODO Code below probably also belongs somewhere else
+(extend-protocol FXStyleSetter
-(def getter first)
+  Node
-(def setter second)
+  (set-style! [this style] (.setStyle ^Node this ^String style) this)
+  MenuItem
+  (set-style! [this style] (.setStyle ^MenuItem this ^String style) this))
 
-(def translation-map
+(extend-type Styleable
-  (atom {:text (with-meta [#'get-value #'set-value!] {:argument String :parent FXValue})
+  FXStyleable
-         :value (with-meta [#'get-value #'set-value!] {:argument Object :parent FXValue})
+  (get-css-meta [this] (.getCssMetaData ^Styleable this))
-         :id (with-meta [#'get-id #'set-id!] {:argument String :parent FXId})
+  (get-pseudo-class-styles [this] (.getPseudoClassStyles ^Styleable this))
-         :graphic (with-meta [#'get-graphic #'set-graphic!] {:argument Node :parent FXGraphic})
+  (get-style [this] (.getStyle ^Styleable this))
-         :content (with-meta [#'get-content #'set-content!] {:argument Node :parent FXContainer})
+  (get-style-classes [this] (.getStyleClass ^Styleable this))
-         :children (with-meta [#'get-subnodes #'set-subnodes!] {:argument java.util.List :parent FXParent})}))
+  (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)))
 
-(declare compile-o-matic)
+(extend-type Stage
-(ann build-node [Any (Map Keyword Any) -> Any])
+  FXStage
-(defn build-node [object props]
+  (get-title [this] (.getTitle ^Stage this))
-  (debug "build-node:" object props)
+  (set-title! [this title] (.setTitle ^Stage this ^String title))
-  (let [obj (eval `(new ~object))]
+  (get-scene [this] (.getScene ^Stage this))
-    (doseq [[k v] props]
+  (set-scene! [this scene] (.setScene ^Stage this ^Scene scene)))
-      (let [translation (get @translation-map k)
-            {:keys [argument parent]} (meta translation)
-            v (compile-o-matic v)]
-        (trace "Key:" k " " (type k) "Value:" v " " (type v))
-        (when (nil? translation)
-          (throw (Exception. (str "Property" k "not available in translation map."))))
-        ;; (when-not ((pred-substitute argument) v)
-        ;;   (throw (Exception. (str "Input type" v "is not compatible with expected type for" k))))
-        ;; (when-not ((pred-substitute parent) obj)
-        ;;   (throw (Exception. (str "Property" k "not available for class" (class obj)))))
-        ((setter translation) obj v)))
-    obj))
 
-(ann resolv-o-matic [(U String Keyword Symbol Class) -> Class])
+(extend-type Scene
-(defn resolv-o-matic [thing]
+  FXScene
-  (cond
+  (get-root [this] (.getRoot ^Scene this))
-    (symbol? thing) (ns-resolve (the-ns 'clojurefx.clojurefx) thing)
+  (set-root! [this root] (.setRoot ^Scene this ^Parent root) this))
-    (keyword? thing) (recur (name thing))
-    (string? thing) (recur (symbol thing))
-    :else thing))
-
-(ann compile [(Vec Any) -> Any])
-(defn compile [[obj params & other]]
-  (assert (map? params))
-  (let [obj (build-node (resolv-o-matic obj) params)]
-    (if (empty? other)
-      obj
-      (flatten (conj (list obj) (compile other))))))
-
-(ann compile-o-matic [Any -> Any])
-(defn compile-o-matic [thing]
-  (if (instance? java.util.List thing)
-    (if (and (not (coll? (first thing))) (map? (second thing)))
-      (compile thing)
-      thing)
-    thing))

src/clojurefx/factory.clj

@@ -0,0 +1,92 @@
+(ns clojurefx.factory
+  (:refer-clojure :exclude [atom doseq let fn defn ref dotimes defprotocol loop for send compile])
+  (:require [clojure.core.typed :refer :all]
+            [clojure.core.typed.unsafe :refer [ignore-with-unckecked-cast]]
+            [taoensso.timbre :as timbre]
+            [clojure.java.io :as io]
+            [clojurefx.clojurefx :refer :all]
+            [clojurefx.protocols :refer :all]))
+
+(tc-ignore (timbre/refer-timbre))
+
+;;## FXMLLoader
+
+(defn load-fxml [filename :- String] :- javafx.scene.Node
+  (let [loader (new javafx.fxml.FXMLLoader)]
+    (.setLocation loader (io/resource ""))
+    (.load loader (-> filename io/resource io/input-stream))))
+
+;;## VectorBuilder
+
+(def getter first)
+(def setter second)
+
+(def translation-map
+  (atom {:text (with-meta [#'get-value #'set-value!] {:argument String :parent FXValue})
+         :value (with-meta [#'get-value #'set-value!] {:argument Object :parent FXValue})
+         :id (with-meta [#'get-id #'set-id!] {:argument String :parent FXId})
+         :graphic (with-meta [#'get-graphic #'set-graphic!] {:argument Node :parent FXGraphic})
+         :content (with-meta [#'get-content #'set-content!] {:argument Node :parent FXContainer})
+         :children (with-meta [#'get-subnodes #'set-subnodes!] {:argument java.util.List :parent FXParent})
+         :title (with-meta [#'get-title #'set-title!] {:argument String :parent FXStage})
+         :scene (with-meta [#'get-scene #'set-scene!] {:argument Scene :parent FXStage})
+         :root (with-meta [#'get-root #'set-root!] {:argument Parent :parent FXScene})}))
+
+(def mandatory-constructor-args
+  (atom {javafx.scene.Scene [:root]}))
+
+(declare compile-o-matic)
+(ann apply-props-to-node [Any (Map Keyword Any) -> Any])
+(defn apply-props-to-node [node props]
+  (doseq [[k v] props]
+    (let [translation (get @translation-map k)
+          {:keys [argument parent]} (meta translation)
+          v (compile-o-matic v)]
+      (trace "Key:" k " " (type k) "Value:" v " " (type v))
+      (when (nil? translation)
+        (throw (Exception. (str "Property" k "not available in translation map."))))
+      ;; (when-not ((pred-substitute argument) v)
+      ;;   (throw (Exception. (str "Input type" v "is not compatible with expected type for" k))))
+      ;; (when-not ((pred-substitute parent) node)
+      ;;   (throw (Exception. (str "Property" k "not available for class" (class node)))))
+      ((setter translation) node v)))
+  node)
+
+(ann build-node [Any (Map Keyword Any) -> Any])
+(defn build-node [object props]
+  (debug "build-node:" object props)
+  (let [mandatory (get mandatory-constructor-args object)
+        form `(~object new)]
+    (apply-props-to-node
+     (-> (reduce (fn [form mandatory]
+                   (if-let [entry (get props mandatory)]
+                     (cons entry form)
+                     form)) form mandatory)
+         reverse
+         eval)
+     (apply dissoc props mandatory))))
+
+(ann resolv-o-matic [(U String Keyword Symbol Class) -> Class])
+(defn resolv-o-matic [thing]
+  (cond
+    (symbol? thing) (ns-resolve (the-ns 'clojurefx.clojurefx) thing)
+    (keyword? thing) (recur (name thing))
+    (string? thing) (recur (symbol thing))
+    :else thing))
+
+(ann compile [(Vec Any) -> Any])
+(defn compile [[obj params & other]]
+  (assert (map? params))
+  (let [obj (build-node (resolv-o-matic obj) params)]
+    (if (empty? other)
+      obj
+      (flatten (conj (list obj) (compile other))))))
+
+(ann compile-o-matic [Any -> Any])
+(defn compile-o-matic [thing]
+  (if (instance? java.util.List thing)
+    (if (and (not (coll? (first thing))) (map? (second thing)))
+      (compile thing)
+      thing)
+    thing))
+

src/clojurefx/protocols.clj

@@ -35,3 +35,35 @@
   FXGraphic
   (get-graphic [this :- A] :- B)
   (set-graphic! [this :- A graphic :- B] :- A))
+
+(defprotocol [[A :variance :covariant :< javafx.css.Styleable]
+              [B :variance :covariant :< javafx.css.Styleable]]
+  FXStyleable
+  "http://download.java.net/jdk8/jfxdocs/javafx/css/Styleable.html"
+  (get-css-meta [this :- A] :- (java.util.List javafx.css.CssMetaData)) ;; TODO
+  (get-pseudo-class-styles [this :- A] :- (javafx.collections.ObservableSet javafx.css.PseudoClass))
+  (get-style [this :- A] :- String)
+  (get-style-classes [this :- A] :- (javafx.collections.ObservableList String))
+  (set-style-classes! [this :- A classes :- java.util.Collection] :- A)
+  (get-styleable-parent [this :- A] :- (U nil B))
+  (get-type-selector [this :- A] :- String))
+
+(defprotocol [[A :variance :covariant]]
+  FXStyleSetter
+  (set-style! [this :- A style :- String] :- A))
+
+(defalias FXStyled (U FXStyleable FXStyleSetter))
+
+(defprotocol [[A :variance :covariant :< javafx.stage.Stage]
+              [B :variance :covariant :< javafx.scene.Scene]]
+  FXStage
+  (get-title [this :- A] :- String)
+  (set-title! [this :- A title :- String] :- A)
+  (get-scene [this :- A] :- B)
+  (set-scene! [this :- A scene :- B] :- A))
+
+(defprotocol [[A :variance :covariant :< javafx.scene.Scene]
+              [B :variance :covariant :< javafx.scene.Parent]]
+  FXScene
+  (get-root [this :- A] :- B)
+  (set-root! [this :- A root :- B] :- A))