diff --git a/.projectile b/.projectile new file mode 100644 index 0000000..e69de29 diff --git a/README.md b/README.md index 7dc22cd..215ea51 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,17 @@ A Clojure wrapper to make working with [JavaFX](http://download.java.net/jdk8/jf ## Features -Nothing yet, but if you give me some time... :) +This is in a very early state, so there isn't much yet, except one thing. + +### Declarative UI programming + +```clojure +(compile [:VBox {:id "TopLevelVBox" + :children [:Label {:text "Hi!"} + :Label {:text "I'm ClojureFX!"} + :HBox {:id "HorizontalBox" + :children [:Button {:text "Alright."}]}]}]) +``` ## TODO diff --git a/build.boot b/build.boot index e69de29..60bfe79 100644 --- a/build.boot +++ b/build.boot @@ -0,0 +1,35 @@ + ;-*- mode: Clojure;-*- +(set-env! :resource-paths #{"src" "java"} + :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"] + + [boot-deps "0.1.2" :scope "test"] + [midje "1.6.3" :scope "test"] + [zilti/boot-midje "0.1.1" :scope "test"] + [zilti/boot-typed "0.1.0" :scope "test"]]) + +(require '[zilti.boot-midje :refer [midje]] + '[zilti.boot-typed :refer [typed]]) + +(def +version+ "0.0.1-SNAPSHOT") + +(task-options! + pom {:project 'ClojureFX + :version +version+ + :description "A Clojure JavaFX wrapper." + :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"} + :autotest true} + typed {:namespaces #{'clojurefx.blargh}} + repl {:server true}) + +(deftask develop + [] + (comp (repl) + (midje) + (watch) + (typed))) diff --git a/src/clojurefx/clojurefx.clj b/src/clojurefx/clojurefx.clj new file mode 100644 index 0000000..ce617e2 --- /dev/null +++ b/src/clojurefx/clojurefx.clj @@ -0,0 +1,189 @@ +(ns clojurefx.clojurefx + (: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-unchecked-cast]] + [taoensso.timbre :as timbre] + [clojure.java.io :as io] + [clojurefx.protocols :refer :all])) + +(defonce force-toolkit-init (javafx.embed.swing.JFXPanel.)) +(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.layout Pane VBox) + (javafx.collections FXCollections ObservableList) + (java.util Collection)) + +;; TODO This belongs elsewhere. +(tc-ignore + (defn load-fxml [filename] + (.load (javafx.fxml.FXMLLoader.) (-> filename io/resource io/input-stream)))) + +;; 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-substitute [clazz] + (clojure.core.typed/pred* (quote clazz) 'clojurefx.clojurefx + (fn [arg] (boolean (instance? clazz arg))))) + +(tc-ignore + (extend-protocol FXValue + Label + (get-value [this] (.getText ^Label this)) + (set-value! [this value] (tc-assert String value) (.setText ^Label this ^String value) this) + TextField + (get-value [this] (.getText ^TextField this)) + (set-value! [this value] (tc-assert String value) (.setText ^TextField this ^String value) this) + TextArea + (get-value [this] (.getText ^TextArea this)) + (set-value! [this value] (tc-assert String value) (.setText ^TextArea this ^String value) this) + CheckBox + (get-value [this] (.isSelected ^CheckBox this)) + (set-value! [this value] (tc-assert Boolean value) (.setSelected ^CheckBox this ^Boolean value) this) + ComboBox + (get-value [this] (let [selection-model (.getSelectionModel ^ComboBox this) + _ (assert (not (nil? selection-model))) + index (.getSelectedIndex ^javafx.scene.control.SingleSelectionModel selection-model)] + (if (>= index 0) + (nth (.getItems ^ComboBox this) index) + (.getSelectedItem ^javafx.scene.control.SingleSelectionModel selection-model)))) + (set-value! [this value] (let [sel-model (.getSelectionModel ^ComboBox this) + item (first (filter #(= value %) (.getItems ^ComboBox this)))] + (if-not (nil? item) + (tc-ignore (.select ^javafx.scene.control.SingleSelectionModel sel-model item)))) this) + Menu + (get-value [this] (.getText ^Menu this)) + (set-value! [this value] (tc-assert String value) (.setText ^Menu this ^String value) this) + MenuItem + (get-value [this] (.getText ^MenuItem this)) + (set-value! [this value] (tc-assert String value) (.setText ^MenuItem this ^String value) this))) + +(tc-ignore + (extend-protocol FXId + Node + (get-id [this] (.getId ^Node this)) + (set-id! [this id] (tc-assert String id) (.setId ^Node 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 + Pane + (get-subnodes [this] (.getChildren ^Pane this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getChildren ^Pane this) ^Collection nodes) this) + TabPane + (get-subnodes [this] (.getTabs ^TabPane this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getTabs ^TabPane this) ^Collection nodes) this) + MenuBar + (get-subnodes [this] (.getMenus ^MenuBar this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getMenus ^MenuBar this) ^Collection nodes) this) + Menu + (get-subnodes [this] (.getItems ^Menu this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getItems ^Menu this) ^Collection nodes) this) + MenuButton + (get-subnodes [this] (.getItems ^MenuButton this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getItems ^MenuButton this) ^Collection nodes) this) + ContextMenu + (get-subnodes [this] (.getItems ^ContextMenu this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getItems ^ContextMenu this) ^Collection nodes) this) + ToolBar + (get-subnodes [this] (.getItems ^ToolBar this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getItems ^ToolBar this) ^Collection nodes) this) + SplitPane + (get-subnodes [this] (.getItems ^SplitPane this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getItems ^SplitPane this) ^Collection nodes) this) + Accordion + (get-subnodes [this] (.getPanes ^Accordion this)) + (set-subnodes! [this nodes] (.setAll ^ObservableList (.getPanes ^Accordion this) ^Collection nodes) this))) + +(tc-ignore + (extend-protocol FXContainer + Tab + (get-content [this] (.getContent ^Tab this)) + (set-content! [this node] (.setContent ^Tab this ^Node node) this) + TitledPane + (get-content [this] (.getContent ^TitledPane this)) + (set-content! [this node] (.setContent ^TitledPane this ^Node node) this) + ScrollPane + (get-content [this] (.getContent ^ScrollPane this)) + (set-content! [this node] (.setContent ^ScrollPane this ^Node node) this))) + +(tc-ignore + (extend-protocol FXGraphic + Labeled + (get-graphic [this] (.getGraphic ^Labeled this)) + (set-graphic! [this graphic] (.setGraphic ^Labeled this ^Node graphic)) + MenuItem + (get-graphic [this] (.getGraphic ^Menu this)) + (set-graphic! [this graphic] (.setGraphic ^Menu this ^Node graphic)))) + + +;; TODO Code below probably also belongs somewhere else +(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})})) + +(declare compile-o-matic) +(ann build-node [Any (Map Keyword Any) -> Any]) +(defn build-node [object props] + (debug "build-node:" object props) + (let [obj (eval `(new ~object))] + (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) 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]) +(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)) diff --git a/src/clojurefx/protocols.clj b/src/clojurefx/protocols.clj new file mode 100644 index 0000000..50893a4 --- /dev/null +++ b/src/clojurefx/protocols.clj @@ -0,0 +1,37 @@ +(ns clojurefx.protocols + (:refer-clojure :exclude [atom doseq let fn defn ref dotimes defprotocol loop for send]) + (:require [clojure.core.typed :refer :all])) + +(declare-protocols FXValue FXId FXParent) +(defprotocol [[A :variance :covariant] + [B :variance :covariant]] + FXValue + (get-value [this :- A] :- B) + (set-value! [this :- A value :- B] :- A)) + +(defprotocol [[A :variance :covariant] + [x :variance :covariant]] + FXId + (get-id [this :- A] :- (U nil String)) + (set-id! [this :- A id :- String] :- A)) + +(defalias FXElement (U FXValue FXId)) + +(defprotocol [[A :variance :covariant] + [B :variance :covariant]] + FXParent + "The ClojureFX extension to javafx.scene.Parent." + (get-subnodes [this :- A] :- B) + (set-subnodes! [this :- A nodes :- B] :- A)) + +(defprotocol [[A :variance :covariant] + [B :variance :covariant]] + FXContainer + (get-content [this :- A] :- B) + (set-content! [this :- A node :- B] :- A)) + +(defprotocol [[A :variance :covariant] + [B :variance :covariant :< javafx.scene.Node]] + FXGraphic + (get-graphic [this :- A] :- B) + (set-graphic! [this :- A graphic :- B] :- A)) diff --git a/test/clojurefx/clojurefx_test.clj b/test/clojurefx/clojurefx_test.clj new file mode 100644 index 0000000..e0d17ec --- /dev/null +++ b/test/clojurefx/clojurefx_test.clj @@ -0,0 +1,13 @@ +(ns clojurefx.clojurefx-test + (:refer-clojure :exclude [compile]) + (:use midje.sweet + clojurefx.clojurefx)) + +(def example-hierarchy + [:VBox {:id "VBox" + :children [:Label {:text "Hi JavaFX!"} + :Label {:text "Hi Clojure!"}]}]) + +(fact "This compiles." + (resolv-o-matic :Label) => javafx.scene.control.Label + (type (compile example-hierarchy)) => javafx.scene.layout.VBox)