199 lines
7.7 KiB
Clojure
199 lines
7.7 KiB
Clojure
(ns clojurefx.controllergen
|
|
;; (:gen-class :name Controllergen
|
|
;; :implements [org.objectweb.asm.Opcodes])
|
|
;; (:import (net.openhft.compiler CachedCompiler CompilerUtils))
|
|
(:import (org.objectweb.asm ClassWriter Opcodes))
|
|
(:use swiss.arrows)
|
|
(:require [clojure.xml :as xml]
|
|
[clojure.zip :as zip]
|
|
[clojure.string :as str]
|
|
[clojure.java.io :as io]
|
|
[taoensso.timbre :as timbre]
|
|
[camel-snake-kebab.core :as csk]
|
|
[clojure.spec.alpha :as s]))
|
|
(timbre/refer-timbre)
|
|
|
|
;; ;; Parser
|
|
|
|
(def imports (list clojure.java.api.Clojure clojure.lang.IFn java.net.URL java.util.ResourceBundle javafx.event.ActionEvent javafx.fxml.FXML))
|
|
|
|
(defn build-imports [filename]
|
|
(->> (slurp filename)
|
|
str/split-lines
|
|
(filter #(str/starts-with? % "<?import"))
|
|
(map #(str/replace % #"<\?import " ""))
|
|
(map #(str/replace % #"\?>" ""))
|
|
(map #(Class/forName %))
|
|
(reduce conj imports)))
|
|
|
|
(defn qualify-class [imports class-str]
|
|
(let [classname (first (filter #(= class-str (last (str/split (pr-str %) #"\."))) imports))
|
|
classfull (str/replace classname #"\." "/")
|
|
classreal (str/split classfull #"\s")]
|
|
(-> (filter #(= class-str (last (str/split (pr-str %) #"\."))) imports)
|
|
first
|
|
(str/replace #"\." "/")
|
|
(str/split #"\s")
|
|
last)))
|
|
|
|
(defn init-class [pkg classname import-classes]
|
|
{:post [(s/valid? (partial instance? org.objectweb.asm.ClassWriter) %)]}
|
|
(debug (str (str/replace pkg #"\." "/") "/" classname))
|
|
|
|
(let [cw (new org.objectweb.asm.ClassWriter 0)
|
|
clazz (.visit cw Opcodes/V1_7
|
|
(+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
|
|
(str (str/replace pkg #"\." "/") "/" classname)
|
|
nil
|
|
"java/lang/Object"
|
|
nil)
|
|
resources_fv (.visitField cw Opcodes/ACC_PRIVATE
|
|
"resources"
|
|
(str "L" (qualify-class import-classes "ResourceBundle") ";")
|
|
nil
|
|
nil)
|
|
url_fv (.visitField cw Opcodes/ACC_PRIVATE
|
|
"location"
|
|
(str "L" (qualify-class import-classes "URL") ";")
|
|
nil
|
|
nil)]
|
|
(-> (.visitAnnotation resources_fv "Ljavafx/fxml/FXML;" true)
|
|
.visitEnd)
|
|
(.visitEnd resources_fv)
|
|
|
|
(-> (.visitAnnotation url_fv "Ljavafx/fxml/FXML;" true)
|
|
.visitEnd)
|
|
(.visitEnd url_fv)
|
|
cw))
|
|
|
|
(defn zip-tree-seq [node]
|
|
(tree-seq (complement string?)
|
|
:content
|
|
node))
|
|
|
|
(defn get-handler-props [{:keys [attrs]}]
|
|
(->> attrs
|
|
(filter #(str/starts-with? (name (key %)) "on"))
|
|
(map val)
|
|
flatten))
|
|
|
|
(defn get-handler-fns [ziptree]
|
|
(->> ziptree
|
|
(map get-handler-props)
|
|
(remove empty?)
|
|
flatten))
|
|
|
|
(defn get-fxid-elems [ziptree]
|
|
(->> ziptree
|
|
(filter #(contains? (:attrs %) :fx:id))))
|
|
|
|
(defn get-controller-class [fxmlzip]
|
|
(->> fxmlzip
|
|
(filter #(contains? (:attrs %) :fx:controller))
|
|
first
|
|
:attrs
|
|
:fx:controller))
|
|
|
|
(defn gen-props [cw [entry & coll] import-classes]
|
|
{:post [(s/valid? (partial instance? org.objectweb.asm.ClassWriter) %)]}
|
|
(if-not (nil? entry)
|
|
(let [fv (.visitField cw Opcodes/ACC_PUBLIC
|
|
(get-in entry [:attrs :fx:id])
|
|
(str "L" (qualify-class import-classes (name (:tag entry))) ";")
|
|
nil nil)]
|
|
(trace "Generating" (get-in entry [:attrs :fx:id]) "with type" (qualify-class import-classes (name (:tag entry))))
|
|
(-> (.visitAnnotation fv "Ljavafx/fxml/FXML;" true)
|
|
.visitEnd)
|
|
(.visitEnd fv)
|
|
(gen-props cw coll import-classes))
|
|
cw))
|
|
|
|
(defn gen-handlers [cw [entry & coll] clj-ns]
|
|
{:post [(s/valid? (partial instance? org.objectweb.asm.ClassWriter) %)]}
|
|
(if-not (nil? entry)
|
|
(let [mv (.visitMethod cw 0
|
|
(subs entry 1)
|
|
"(Ljavafx/event/Event;)V"
|
|
nil nil)]
|
|
(trace "Generating handler" (subs entry 1) "for" entry)
|
|
(-> (.visitAnnotation mv "Ljavafx/fxml/FXML;" true)
|
|
.visitEnd)
|
|
(.visitCode mv)
|
|
(.visitLdcInsn mv clj-ns)
|
|
(.visitLdcInsn mv (csk/->kebab-case (subs entry 1)))
|
|
(.visitMethodInsn mv Opcodes/INVOKESTATIC "clojure/java/api/Clojure" "var" "(Ljava/lang/Object;Ljava/lang/Object;)Lclojure/lang/IFn;" false)
|
|
(.visitVarInsn mv Opcodes/ALOAD 0)
|
|
(.visitVarInsn mv Opcodes/ALOAD 1)
|
|
(.visitMethodInsn mv Opcodes/INVOKEINTERFACE "clojure/lang/IFn" "invoke" "(Ljava/lang/Object;Ljava/lang/Object;)Ljava/lang/Object;" true)
|
|
(.visitInsn mv Opcodes/POP)
|
|
(.visitInsn mv Opcodes/RETURN)
|
|
(.visitMaxs mv 3 2)
|
|
(.visitEnd mv)
|
|
|
|
(gen-handlers cw coll clj-ns))
|
|
cw))
|
|
|
|
(defn gen-initializer [cw [clj-ns clj-fn]]
|
|
{:post [(s/valid? (partial instance? org.objectweb.asm.ClassWriter) %)]}
|
|
(trace clj-ns clj-fn)
|
|
(let [mv (.visitMethod cw Opcodes/ACC_PUBLIC "initialize" "()V" nil nil)
|
|
init-mv (.visitMethod cw Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)]
|
|
(.visitCode mv)
|
|
(-> (.visitAnnotation mv "Ljavafx/fxml/FXML;" true)
|
|
.visitEnd)
|
|
(.visitLdcInsn mv clj-ns)
|
|
(.visitLdcInsn mv clj-fn)
|
|
(.visitMethodInsn mv Opcodes/INVOKESTATIC "clojure/java/api/Clojure" "var" "(Ljava/lang/Object;Ljava/lang/Object;)Lclojure/lang/IFn;" false)
|
|
(.visitVarInsn mv Opcodes/ALOAD 0)
|
|
(.visitMethodInsn mv Opcodes/INVOKEINTERFACE "clojure/lang/IFn" "invoke" "(Ljava/lang/Object;)Ljava/lang/Object;" true)
|
|
(.visitInsn mv Opcodes/POP)
|
|
(.visitInsn mv Opcodes/RETURN)
|
|
(.visitMaxs mv 2 1)
|
|
(.visitEnd mv)
|
|
|
|
(.visitCode init-mv)
|
|
(.visitVarInsn init-mv Opcodes/ALOAD 0)
|
|
(.visitMethodInsn init-mv Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V" false)
|
|
(.visitInsn init-mv Opcodes/RETURN)
|
|
(.visitMaxs init-mv 1 1)
|
|
(.visitEnd init-mv)
|
|
|
|
cw))
|
|
|
|
(defn gen-fx-controller [fxmlzip fxmlpath [clj-ns clj-fn] [pkg classname]]
|
|
(let [fxid-elems (get-fxid-elems fxmlzip)
|
|
handler-fns (get-handler-fns fxmlzip)
|
|
import-classes (build-imports fxmlpath)
|
|
inited-class (init-class pkg classname import-classes)
|
|
propped-class (gen-props inited-class fxid-elems import-classes)
|
|
initializer-class (gen-initializer propped-class [clj-ns clj-fn])
|
|
handled-class (gen-handlers initializer-class handler-fns clj-ns)]
|
|
(trace (pr-str handler-fns))
|
|
(.visitEnd handled-class)
|
|
(.toByteArray handled-class)))
|
|
|
|
;; ;; Plumber
|
|
|
|
(defn define-class [name bytes]
|
|
(let [cl (.getClassLoader clojure.lang.RT)
|
|
method (.getDeclaredMethod java.lang.ClassLoader "defineClass"
|
|
(into-array [String (Class/forName "[B") (Integer/TYPE) (Integer/TYPE)]))]
|
|
(try
|
|
(.setAccessible method true)
|
|
(.invoke method cl (into-array Object [name bytes (int 0) (int (count bytes))]))
|
|
(finally (.setAccessible method false)))))
|
|
|
|
(defn gen-fx-controller-class [fxmlpath clj-fn]
|
|
(let [clj-fn ^String (if (symbol? clj-fn)
|
|
(str (namespace clj-fn) "/" (name clj-fn))
|
|
clj-fn)
|
|
fxmlzip (zip-tree-seq (xml/parse (io/input-stream fxmlpath)))
|
|
clazz (get-controller-class fxmlzip)
|
|
[pkg classname] (reverse (map str/reverse (str/split (str/reverse clazz) #"\." 2)))
|
|
cljvec (str/split clj-fn #"/")]
|
|
(try
|
|
(Class/forName (str pkg "." classname))
|
|
(catch Exception e
|
|
(define-class (str pkg "." classname)
|
|
(gen-fx-controller fxmlzip fxmlpath cljvec [pkg classname]))))))
|