Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
(ns defwrapper
(:require [clojure.string :as str]))
(set! *warn-on-reflection* true)
(defn class-methods [^Class class]
(seq (.getMethods class)))
(defn constructors [^Class klazz]
(.getDeclaredConstructors klazz))
(defn return-type [^java.lang.reflect.Method method]
(.getReturnType method))
(defn parameter-types [^java.lang.reflect.Method method]
(seq (.getParameterTypes method)))
(defn parameter-count [^java.lang.reflect.Method method]
(.getParameterCount method))
(defn method-name [^java.lang.reflect.Method method]
(.getName method))
(defn class-name [^Class klazz]
(symbol (.getName klazz)))
(defn camel->kebab
(-> string
(clojure.string/replace #"(.)([A-Z][a-z]+)" "$1-$2")
(clojure.string/replace #"([a-z0-9])([A-Z])" "$1-$2")
(defn class->name [^Class class]
(if (.isArray class)
(str (.getName (.getComponentType class)) "-array")
(.getName class))
(str/replace "." "-")))
(defn method-static? [^java.lang.reflect.Method method]
(java.lang.reflect.Modifier/isStatic (.getModifiers method)))
(defn method-public? [^java.lang.reflect.Method method]
(java.lang.reflect.Modifier/isPublic (.getModifiers method)))
(defn primitive-class [sym]
('{byte java.lang.Byte/TYPE
short java.lang.Short/TYPE
int java.lang.Integer/TYPE
long java.lang.Long/TYPE
float java.lang.Float/TYPE
double java.lang.Double/TYPE
char java.lang.Character/TYPE
boolean java.lang.Boolean/TYPE} sym sym))
(defn array-class [klz]
(class (into-array klz [])))
(defn ensure-boxed [t]
(get '{byte java.lang.Byte
short java.lang.Short
int java.lang.Integer
long java.lang.Long
float java.lang.Float
double java.lang.Double
char java.lang.Character
boolean java.lang.Boolean
void java.lang.Object}
t t))
(defn ensure-boxed-long-double
"Allow long and double, box everything else."
(let [t (if (instance? Class c)
(class-name c)
(get '{byte java.lang.Byte
short java.lang.Short
int java.lang.Integer
float java.lang.Float
char java.lang.Character
boolean java.lang.Boolean
void java.lang.Object}
t t)))
(defn tagged [value tag]
(let [tag (if (and (instance? Class tag) (.isArray ^Class tag))
`(array-class ~(primitive-class (class-name (.getComponentType ^Class tag))))
(vary-meta value assoc :tag (ensure-boxed-long-double tag))))
(defn tagged-local [value tag]
(let [tag (ensure-boxed-long-double tag)]
(= 'long tag)
`(long ~value)
(= 'double tag)
`(double ~value)
(vary-meta value assoc :tag tag))))
(defn wrapper-multi-tail [klazz methods]
(let [static? (method-static? (first methods))
this (gensym "this")
arg-vec (take (parameter-count (first methods)) (repeatedly gensym))
ret (if (apply = (map return-type methods))
(return-type (first methods))
`(~(tagged `[~@(when-not static? [this]) ~@arg-vec] ret)
(fn [method]
`[(and ~@(map (fn [sym ^Class klz]
`(instance? ~(ensure-boxed (class-name klz)) ~sym))
(parameter-types method)))
(let [~@(mapcat (fn [sym ^Class klz]
[sym (tagged-local sym klz)])
(parameter-types method))]
(~(if static?
(symbol (str klazz) (method-name method))
(symbol (str "." (method-name method))))
~@(when-not static? [(tagged this klazz)])
(defn wrapper-tail [klazz method]
(let [nam (method-name method)
ret (return-type method)
par (parameter-types method)
static? (method-static? method)
arg-vec (into (if static? [] [(tagged (gensym "this") klazz)])
(map #(tagged (gensym (class->name %)) %))
`(~(tagged arg-vec ret)
(~(if static?
(symbol (str klazz) nam)
(symbol (str "." nam))) ~@(map #(vary-meta % dissoc :tag) arg-vec)))))
(defn method-wrapper-form [fname klazz methods]
(let [arities (group-by parameter-count methods)]
`(defn ~fname
{:arglists '~(map (comp (partial into [klazz])
parameter-types) methods)}
~@(map (fn [[cnt meths]]
(if (= 1 (count meths))
(wrapper-tail klazz (first meths))
(wrapper-multi-tail klazz meths)))
(defmacro defwrapper [klazz & [prefix]]
(let [methods (->> klazz
(filter method-public?)
(remove (set (class-methods Object)))
(group-by method-name))]
~@(for [[mname meths] methods
:let [fname (symbol (str prefix (camel->kebab mname)))]]
(method-wrapper-form fname klazz meths)))))
#_(binding [*print-meta* true]
(prn (macroexpand-1 '(defwrapper javax.sound.midi.MidiSystem "midi-sys-"))))
(defwrapper javax.sound.midi.MidiSystem "midi-sys-")
(defwrapper javax.sound.midi.Synthesizer "synth-")
(defwrapper javax.sound.midi.MidiChannel "chan-")
;;; Play some tunes
(def synth (midi-sys-get-synthesizer))
(synth-open synth)
(def chan (first (synth-get-channels synth)))
(meta #'synth-get-channels)
(chan-note-on chan 60 600)
(chan-note-on chan 64 600)
(chan-note-on chan 67 600)
(Thread/sleep 1100)
(chan-note-on chan 60 600)
(chan-note-on chan 64 600)
(chan-note-on chan 67 600)
(chan-note-on chan 71 600)))
;; TODO:
;; - better varargs
;; - test if (long ... ) actually works
;; - prevent unnecessary boxing
;; - constructors
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.