From 94968a61aad0dae50d34ea67abbdfe0c3b899bc0 Mon Sep 17 00:00:00 2001 From: "dziltener@lyrion.ch" Date: Fri, 16 Jan 2015 21:26:46 +0000 Subject: [PATCH] Restructured code. Improved 'compile'. Added more wrappers. --- README.md | 10 +-- build.boot | 9 +-- src/clojurefx/clojurefx.clj | 131 ++++++++++++++++++------------------ src/clojurefx/factory.clj | 92 +++++++++++++++++++++++++ src/clojurefx/protocols.clj | 32 +++++++++ 5 files changed, 200 insertions(+), 74 deletions(-) create mode 100644 src/clojurefx/factory.clj diff --git a/README.md b/README.md index 215ea51..054eb1c 100644 --- a/README.md +++ b/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" - :children [:Label {:text "Hi!"} - :Label {:text "I'm ClojureFX!"} - :HBox {:id "HorizontalBox" - :children [:Button {:text "Alright."}]}]}]) +(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 60bfe79..ae4b812 100644 --- a/build.boot +++ b/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" - :scm {:url "https://bitbucket.com/zilti/ClojureFX"} + :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"} diff --git a/src/clojurefx/clojurefx.clj b/src/clojurefx/clojurefx.clj index ce617e2..fbfc93a 100644 --- a/src/clojurefx/clojurefx.clj +++ b/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 - (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))) + 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 @@ -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 -(def getter first) -(def setter second) +(extend-protocol FXStyleSetter + Node + (set-style! [this style] (.setStyle ^Node this ^String style) this) + MenuItem + (set-style! [this style] (.setStyle ^MenuItem this ^String style) this)) -(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})})) +(extend-type Styleable + 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))) -(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)) +(extend-type Stage + 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))) -(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)) +(extend-type Scene + FXScene + (get-root [this] (.getRoot ^Scene this)) + (set-root! [this root] (.setRoot ^Scene this ^Parent root) this)) diff --git a/src/clojurefx/factory.clj b/src/clojurefx/factory.clj new file mode 100644 index 0000000..f6c775a --- /dev/null +++ b/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)) + diff --git a/src/clojurefx/protocols.clj b/src/clojurefx/protocols.clj index 50893a4..dc2c973 100644 --- a/src/clojurefx/protocols.clj +++ b/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))