Created
March 15, 2011 21:22
-
-
Save Chouser/871513 to your computer and use it in GitHub Desktop.
Like clojure.core/proxy, but accepts a syntax like reify
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(let [arrays '{objects "Ljava.lang.Object;", | |
ints I, longs J, floats F, doubles D, chars C, | |
shorts S, bytes B, booleans Z}] | |
(defn qualify-tag [tag] | |
(when tag | |
(let [cls (if-let [array (arrays tag)] | |
(clojure.lang.RT/classForName (str "[" array)) | |
(resolve tag))] | |
(assert (class? cls)) | |
(symbol (pr-str cls)))))) | |
(defn sig-match [cs is] | |
(every? true? (map instance? cs is))) | |
(defmacro proxy* [& xs] | |
(let [[super args] (->> (partition 2 1 xs) | |
(filter (fn [[c a]] (and (symbol? c) (vector? a)))) | |
first) | |
bases (remove #(= % super) (filter symbol? xs)) | |
badargs #(throw (IllegalArgumentException. (apply str %&))) | |
methmap (reduce ; group methods by name and arg-count | |
(fn [methmap [mname [this & args] & body]] | |
(let [mname (symbol nil (name mname)) | |
tags (vec (map #(-> % meta :tag qualify-tag) args))] | |
(update-in | |
methmap | |
[mname (count args) tags] | |
#(if (nil? %1) | |
%2 | |
(badargs "Redefinded method '" mname | |
"' with args " (pr-str tags))) | |
[this (vec args) body]))) | |
{} (filter list? xs)) | |
bodies | |
(fn [mname sigs] | |
(for [[arg-count sigs] sigs] ; one fn body per arg-count | |
(let [genthis (gensym "this__") | |
genargs (vec (map #(gensym (str "arg" % "__")) | |
(range arg-count))) | |
lasttags (first (last sigs)) | |
conds (for [[tags [this args body]] sigs] | |
(let [locals `[~this ~genthis | |
~@(interleave args genargs)]] | |
(if-not (= tags lasttags) | |
[tags `(let ~locals ~@body)] | |
[`(let ~locals | |
~@(when *assert* | |
[`(when-not (sig-match ~tags ~args) | |
(~badargs | |
"No method '" '~mname "' for " | |
(-> (map class ~args) | |
vec pr-str)))]) | |
~@body)])))] | |
`([~genthis ~@genargs] | |
(condp sig-match ~genargs | |
~@(apply concat conds))))))] | |
`(doto | |
(proxy [~@(when super [super]) ~@bases] [~@args]) | |
(init-proxy | |
~(zipmap | |
(map str (keys methmap)) | |
(for [[mname sigs] methmap] | |
`(fn ~mname ~@(bodies mname sigs)))))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment