|
rlm@10
|
1 ; Copyright (c) Rich Hickey. All rights reserved.
|
|
rlm@10
|
2 ; The use and distribution terms for this software are covered by the
|
|
rlm@10
|
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
4 ; which can be found in the file epl-v10.html at the root of this distribution.
|
|
rlm@10
|
5 ; By using this software in any fashion, you are agreeing to be bound by
|
|
rlm@10
|
6 ; the terms of this license.
|
|
rlm@10
|
7 ; You must not remove this notice, or any other, from this software.
|
|
rlm@10
|
8
|
|
rlm@10
|
9 (in-ns 'clojure.core)
|
|
rlm@10
|
10
|
|
rlm@10
|
11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
12
|
|
rlm@10
|
13 (defn namespace-munge
|
|
rlm@10
|
14 "Convert a Clojure namespace name to a legal Java package name."
|
|
rlm@10
|
15 {:added "1.2"}
|
|
rlm@10
|
16 [ns]
|
|
rlm@10
|
17 (.replace (str ns) \- \_))
|
|
rlm@10
|
18
|
|
rlm@10
|
19 ;for now, built on gen-interface
|
|
rlm@10
|
20 (defmacro definterface
|
|
rlm@10
|
21 [name & sigs]
|
|
rlm@10
|
22 (let [tag (fn [x] (or (:tag (meta x)) Object))
|
|
rlm@10
|
23 psig (fn [[name [& args]]]
|
|
rlm@10
|
24 (vector name (vec (map tag args)) (tag name) (map meta args)))
|
|
rlm@10
|
25 cname (with-meta (symbol (str (namespace-munge *ns*) "." name)) (meta name))]
|
|
rlm@10
|
26 `(let []
|
|
rlm@10
|
27 (gen-interface :name ~cname :methods ~(vec (map psig sigs)))
|
|
rlm@10
|
28 (import ~cname))))
|
|
rlm@10
|
29
|
|
rlm@10
|
30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
31
|
|
rlm@10
|
32 (defn- parse-opts [s]
|
|
rlm@10
|
33 (loop [opts {} [k v & rs :as s] s]
|
|
rlm@10
|
34 (if (keyword? k)
|
|
rlm@10
|
35 (recur (assoc opts k v) rs)
|
|
rlm@10
|
36 [opts s])))
|
|
rlm@10
|
37
|
|
rlm@10
|
38 (defn- parse-impls [specs]
|
|
rlm@10
|
39 (loop [ret {} s specs]
|
|
rlm@10
|
40 (if (seq s)
|
|
rlm@10
|
41 (recur (assoc ret (first s) (take-while seq? (next s)))
|
|
rlm@10
|
42 (drop-while seq? (next s)))
|
|
rlm@10
|
43 ret)))
|
|
rlm@10
|
44
|
|
rlm@10
|
45 (defn- parse-opts+specs [opts+specs]
|
|
rlm@10
|
46 (let [[opts specs] (parse-opts opts+specs)
|
|
rlm@10
|
47 impls (parse-impls specs)
|
|
rlm@10
|
48 interfaces (-> (map #(if (var? (resolve %))
|
|
rlm@10
|
49 (:on (deref (resolve %)))
|
|
rlm@10
|
50 %)
|
|
rlm@10
|
51 (keys impls))
|
|
rlm@10
|
52 set
|
|
rlm@10
|
53 (disj 'Object 'java.lang.Object)
|
|
rlm@10
|
54 vec)
|
|
rlm@10
|
55 methods (map (fn [[name params & body]]
|
|
rlm@10
|
56 (cons name (maybe-destructured params body)))
|
|
rlm@10
|
57 (apply concat (vals impls)))]
|
|
rlm@10
|
58 (when-let [bad-opts (seq (remove #{:no-print} (keys opts)))]
|
|
rlm@10
|
59 (throw (IllegalArgumentException. (apply print-str "Unsupported option(s) -" bad-opts))))
|
|
rlm@10
|
60 [interfaces methods opts]))
|
|
rlm@10
|
61
|
|
rlm@10
|
62 (defmacro reify
|
|
rlm@10
|
63 "reify is a macro with the following structure:
|
|
rlm@10
|
64
|
|
rlm@10
|
65 (reify options* specs*)
|
|
rlm@10
|
66
|
|
rlm@10
|
67 Currently there are no options.
|
|
rlm@10
|
68
|
|
rlm@10
|
69 Each spec consists of the protocol or interface name followed by zero
|
|
rlm@10
|
70 or more method bodies:
|
|
rlm@10
|
71
|
|
rlm@10
|
72 protocol-or-interface-or-Object
|
|
rlm@10
|
73 (methodName [args+] body)*
|
|
rlm@10
|
74
|
|
rlm@10
|
75 Methods should be supplied for all methods of the desired
|
|
rlm@10
|
76 protocol(s) and interface(s). You can also define overrides for
|
|
rlm@10
|
77 methods of Object. Note that the first parameter must be supplied to
|
|
rlm@10
|
78 correspond to the target object ('this' in Java parlance). Thus
|
|
rlm@10
|
79 methods for interfaces will take one more argument than do the
|
|
rlm@10
|
80 interface declarations. Note also that recur calls to the method
|
|
rlm@10
|
81 head should *not* pass the target object, it will be supplied
|
|
rlm@10
|
82 automatically and can not be substituted.
|
|
rlm@10
|
83
|
|
rlm@10
|
84 The return type can be indicated by a type hint on the method name,
|
|
rlm@10
|
85 and arg types can be indicated by a type hint on arg names. If you
|
|
rlm@10
|
86 leave out all hints, reify will try to match on same name/arity
|
|
rlm@10
|
87 method in the protocol(s)/interface(s) - this is preferred. If you
|
|
rlm@10
|
88 supply any hints at all, no inference is done, so all hints (or
|
|
rlm@10
|
89 default of Object) must be correct, for both arguments and return
|
|
rlm@10
|
90 type. If a method is overloaded in a protocol/interface, multiple
|
|
rlm@10
|
91 independent method definitions must be supplied. If overloaded with
|
|
rlm@10
|
92 same arity in an interface you must specify complete hints to
|
|
rlm@10
|
93 disambiguate - a missing hint implies Object.
|
|
rlm@10
|
94
|
|
rlm@10
|
95 recur works to method heads The method bodies of reify are lexical
|
|
rlm@10
|
96 closures, and can refer to the surrounding local scope:
|
|
rlm@10
|
97
|
|
rlm@10
|
98 (str (let [f \"foo\"]
|
|
rlm@10
|
99 (reify Object
|
|
rlm@10
|
100 (toString [this] f))))
|
|
rlm@10
|
101 == \"foo\"
|
|
rlm@10
|
102
|
|
rlm@10
|
103 (seq (let [f \"foo\"]
|
|
rlm@10
|
104 (reify clojure.lang.Seqable
|
|
rlm@10
|
105 (seq [this] (seq f)))))
|
|
rlm@10
|
106 == (\\f \\o \\o))"
|
|
rlm@10
|
107 {:added "1.2"}
|
|
rlm@10
|
108 [& opts+specs]
|
|
rlm@10
|
109 (let [[interfaces methods] (parse-opts+specs opts+specs)]
|
|
rlm@10
|
110 (with-meta `(reify* ~interfaces ~@methods) (meta &form))))
|
|
rlm@10
|
111
|
|
rlm@10
|
112 (defn hash-combine [x y]
|
|
rlm@10
|
113 (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y)))
|
|
rlm@10
|
114
|
|
rlm@10
|
115 (defn munge [s]
|
|
rlm@10
|
116 ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s))))
|
|
rlm@10
|
117
|
|
rlm@10
|
118 (defn- imap-cons
|
|
rlm@10
|
119 [^IPersistentMap this o]
|
|
rlm@10
|
120 (cond
|
|
rlm@10
|
121 (instance? java.util.Map$Entry o)
|
|
rlm@10
|
122 (let [^java.util.Map$Entry pair o]
|
|
rlm@10
|
123 (.assoc this (.getKey pair) (.getValue pair)))
|
|
rlm@10
|
124 (instance? clojure.lang.IPersistentVector o)
|
|
rlm@10
|
125 (let [^clojure.lang.IPersistentVector vec o]
|
|
rlm@10
|
126 (.assoc this (.nth vec 0) (.nth vec 1)))
|
|
rlm@10
|
127 :else (loop [this this
|
|
rlm@10
|
128 o o]
|
|
rlm@10
|
129 (if (seq o)
|
|
rlm@10
|
130 (let [^java.util.Map$Entry pair (first o)]
|
|
rlm@10
|
131 (recur (.assoc this (.getKey pair) (.getValue pair)) (rest o)))
|
|
rlm@10
|
132 this))))
|
|
rlm@10
|
133
|
|
rlm@10
|
134 (defn- emit-defrecord
|
|
rlm@10
|
135 "Do not use this directly - use defrecord"
|
|
rlm@10
|
136 {:added "1.2"}
|
|
rlm@10
|
137 [tagname name fields interfaces methods]
|
|
rlm@10
|
138 (let [tag (keyword (str *ns*) (str tagname))
|
|
rlm@10
|
139 classname (with-meta (symbol (str *ns* "." name)) (meta name))
|
|
rlm@10
|
140 interfaces (vec interfaces)
|
|
rlm@10
|
141 interface-set (set (map resolve interfaces))
|
|
rlm@10
|
142 methodname-set (set (map first methods))
|
|
rlm@10
|
143 hinted-fields fields
|
|
rlm@10
|
144 fields (vec (map #(with-meta % nil) fields))
|
|
rlm@10
|
145 base-fields fields
|
|
rlm@10
|
146 fields (conj fields '__meta '__extmap)]
|
|
rlm@10
|
147 (when (some #{:volatile-mutable :unsynchronized-mutable} (mapcat (comp keys meta) hinted-fields))
|
|
rlm@10
|
148 (throw (IllegalArgumentException. ":volatile-mutable or :unsynchronized-mutable not supported for record fields")))
|
|
rlm@10
|
149 (let [gs (gensym)]
|
|
rlm@10
|
150 (letfn
|
|
rlm@10
|
151 [(eqhash [[i m]]
|
|
rlm@10
|
152 [i
|
|
rlm@10
|
153 (conj m
|
|
rlm@10
|
154 `(hashCode [this#] (clojure.lang.APersistentMap/mapHash this#))
|
|
rlm@10
|
155 `(equals [this# ~gs] (clojure.lang.APersistentMap/mapEquals this# ~gs)))])
|
|
rlm@10
|
156 (iobj [[i m]]
|
|
rlm@10
|
157 [(conj i 'clojure.lang.IObj)
|
|
rlm@10
|
158 (conj m `(meta [this#] ~'__meta)
|
|
rlm@10
|
159 `(withMeta [this# ~gs] (new ~tagname ~@(replace {'__meta gs} fields))))])
|
|
rlm@10
|
160 (ilookup [[i m]]
|
|
rlm@10
|
161 [(conj i 'clojure.lang.ILookup 'clojure.lang.IKeywordLookup)
|
|
rlm@10
|
162 (conj m `(valAt [this# k#] (.valAt this# k# nil))
|
|
rlm@10
|
163 `(valAt [this# k# else#]
|
|
rlm@10
|
164 (case k# ~@(mapcat (fn [fld] [(keyword fld) fld])
|
|
rlm@10
|
165 base-fields)
|
|
rlm@10
|
166 (get ~'__extmap k# else#)))
|
|
rlm@10
|
167 `(getLookupThunk [this# k#]
|
|
rlm@10
|
168 (let [~'gclass (class this#)]
|
|
rlm@10
|
169 (case k#
|
|
rlm@10
|
170 ~@(let [hinted-target (with-meta 'gtarget {:tag tagname})]
|
|
rlm@10
|
171 (mapcat
|
|
rlm@10
|
172 (fn [fld]
|
|
rlm@10
|
173 [(keyword fld)
|
|
rlm@10
|
174 `(reify clojure.lang.ILookupThunk
|
|
rlm@10
|
175 (get [~'thunk ~'gtarget]
|
|
rlm@10
|
176 (if (identical? (class ~'gtarget) ~'gclass)
|
|
rlm@10
|
177 (. ~hinted-target ~(keyword fld))
|
|
rlm@10
|
178 ~'thunk)))])
|
|
rlm@10
|
179 base-fields))
|
|
rlm@10
|
180 nil))))])
|
|
rlm@10
|
181 (imap [[i m]]
|
|
rlm@10
|
182 [(conj i 'clojure.lang.IPersistentMap)
|
|
rlm@10
|
183 (conj m
|
|
rlm@10
|
184 `(count [this#] (+ ~(count base-fields) (count ~'__extmap)))
|
|
rlm@10
|
185 `(empty [this#] (throw (UnsupportedOperationException. (str "Can't create empty: " ~(str classname)))))
|
|
rlm@10
|
186 `(cons [this# e#] ((var imap-cons) this# e#))
|
|
rlm@10
|
187 `(equiv [this# ~gs]
|
|
rlm@10
|
188 (boolean
|
|
rlm@10
|
189 (or (identical? this# ~gs)
|
|
rlm@10
|
190 (when (identical? (class this#) (class ~gs))
|
|
rlm@10
|
191 (let [~gs ~(with-meta gs {:tag tagname})]
|
|
rlm@10
|
192 (and ~@(map (fn [fld] `(= ~fld (. ~gs ~fld))) base-fields)
|
|
rlm@10
|
193 (= ~'__extmap (. ~gs ~'__extmap))))))))
|
|
rlm@10
|
194 `(containsKey [this# k#] (not (identical? this# (.valAt this# k# this#))))
|
|
rlm@10
|
195 `(entryAt [this# k#] (let [v# (.valAt this# k# this#)]
|
|
rlm@10
|
196 (when-not (identical? this# v#)
|
|
rlm@10
|
197 (clojure.lang.MapEntry. k# v#))))
|
|
rlm@10
|
198 `(seq [this#] (seq (concat [~@(map #(list `new `clojure.lang.MapEntry (keyword %) %) base-fields)]
|
|
rlm@10
|
199 ~'__extmap)))
|
|
rlm@10
|
200 `(assoc [this# k# ~gs]
|
|
rlm@10
|
201 (condp identical? k#
|
|
rlm@10
|
202 ~@(mapcat (fn [fld]
|
|
rlm@10
|
203 [(keyword fld) (list* `new tagname (replace {fld gs} fields))])
|
|
rlm@10
|
204 base-fields)
|
|
rlm@10
|
205 (new ~tagname ~@(remove #{'__extmap} fields) (assoc ~'__extmap k# ~gs))))
|
|
rlm@10
|
206 `(without [this# k#] (if (contains? #{~@(map keyword base-fields)} k#)
|
|
rlm@10
|
207 (dissoc (with-meta (into {} this#) ~'__meta) k#)
|
|
rlm@10
|
208 (new ~tagname ~@(remove #{'__extmap} fields)
|
|
rlm@10
|
209 (not-empty (dissoc ~'__extmap k#))))))])
|
|
rlm@10
|
210 (ijavamap [[i m]]
|
|
rlm@10
|
211 [(conj i 'java.util.Map 'java.io.Serializable)
|
|
rlm@10
|
212 (conj m
|
|
rlm@10
|
213 `(size [this#] (.count this#))
|
|
rlm@10
|
214 `(isEmpty [this#] (= 0 (.count this#)))
|
|
rlm@10
|
215 `(containsValue [this# v#] (boolean (some #{v#} (vals this#))))
|
|
rlm@10
|
216 `(get [this# k#] (.valAt this# k#))
|
|
rlm@10
|
217 `(put [this# k# v#] (throw (UnsupportedOperationException.)))
|
|
rlm@10
|
218 `(remove [this# k#] (throw (UnsupportedOperationException.)))
|
|
rlm@10
|
219 `(putAll [this# m#] (throw (UnsupportedOperationException.)))
|
|
rlm@10
|
220 `(clear [this#] (throw (UnsupportedOperationException.)))
|
|
rlm@10
|
221 `(keySet [this#] (set (keys this#)))
|
|
rlm@10
|
222 `(values [this#] (vals this#))
|
|
rlm@10
|
223 `(entrySet [this#] (set this#)))])
|
|
rlm@10
|
224 ]
|
|
rlm@10
|
225 (let [[i m] (-> [interfaces methods] eqhash iobj ilookup imap ijavamap)]
|
|
rlm@10
|
226 `(deftype* ~tagname ~classname ~(conj hinted-fields '__meta '__extmap)
|
|
rlm@10
|
227 :implements ~(vec i)
|
|
rlm@10
|
228 ~@m))))))
|
|
rlm@10
|
229
|
|
rlm@10
|
230 (defmacro defrecord
|
|
rlm@10
|
231 "Alpha - subject to change
|
|
rlm@10
|
232
|
|
rlm@10
|
233 (defrecord name [fields*] options* specs*)
|
|
rlm@10
|
234
|
|
rlm@10
|
235 Currently there are no options.
|
|
rlm@10
|
236
|
|
rlm@10
|
237 Each spec consists of a protocol or interface name followed by zero
|
|
rlm@10
|
238 or more method bodies:
|
|
rlm@10
|
239
|
|
rlm@10
|
240 protocol-or-interface-or-Object
|
|
rlm@10
|
241 (methodName [args*] body)*
|
|
rlm@10
|
242
|
|
rlm@10
|
243 Dynamically generates compiled bytecode for class with the given
|
|
rlm@10
|
244 name, in a package with the same name as the current namespace, the
|
|
rlm@10
|
245 given fields, and, optionally, methods for protocols and/or
|
|
rlm@10
|
246 interfaces.
|
|
rlm@10
|
247
|
|
rlm@10
|
248 The class will have the (immutable) fields named by
|
|
rlm@10
|
249 fields, which can have type hints. Protocols/interfaces and methods
|
|
rlm@10
|
250 are optional. The only methods that can be supplied are those
|
|
rlm@10
|
251 declared in the protocols/interfaces. Note that method bodies are
|
|
rlm@10
|
252 not closures, the local environment includes only the named fields,
|
|
rlm@10
|
253 and those fields can be accessed directy.
|
|
rlm@10
|
254
|
|
rlm@10
|
255 Method definitions take the form:
|
|
rlm@10
|
256
|
|
rlm@10
|
257 (methodname [args*] body)
|
|
rlm@10
|
258
|
|
rlm@10
|
259 The argument and return types can be hinted on the arg and
|
|
rlm@10
|
260 methodname symbols. If not supplied, they will be inferred, so type
|
|
rlm@10
|
261 hints should be reserved for disambiguation.
|
|
rlm@10
|
262
|
|
rlm@10
|
263 Methods should be supplied for all methods of the desired
|
|
rlm@10
|
264 protocol(s) and interface(s). You can also define overrides for
|
|
rlm@10
|
265 methods of Object. Note that a parameter must be supplied to
|
|
rlm@10
|
266 correspond to the target object ('this' in Java parlance). Thus
|
|
rlm@10
|
267 methods for interfaces will take one more argument than do the
|
|
rlm@10
|
268 interface declarations. Note also that recur calls to the method
|
|
rlm@10
|
269 head should *not* pass the target object, it will be supplied
|
|
rlm@10
|
270 automatically and can not be substituted.
|
|
rlm@10
|
271
|
|
rlm@10
|
272 In the method bodies, the (unqualified) name can be used to name the
|
|
rlm@10
|
273 class (for calls to new, instance? etc).
|
|
rlm@10
|
274
|
|
rlm@10
|
275 The class will have implementations of several (clojure.lang)
|
|
rlm@10
|
276 interfaces generated automatically: IObj (metadata support) and
|
|
rlm@10
|
277 IPersistentMap, and all of their superinterfaces.
|
|
rlm@10
|
278
|
|
rlm@10
|
279 In addition, defrecord will define type-and-value-based equality and
|
|
rlm@10
|
280 hashCode.
|
|
rlm@10
|
281
|
|
rlm@10
|
282 When AOT compiling, generates compiled bytecode for a class with the
|
|
rlm@10
|
283 given name (a symbol), prepends the current ns as the package, and
|
|
rlm@10
|
284 writes the .class file to the *compile-path* directory.
|
|
rlm@10
|
285
|
|
rlm@10
|
286 Two constructors will be defined, one taking the designated fields
|
|
rlm@10
|
287 followed by a metadata map (nil for none) and an extension field
|
|
rlm@10
|
288 map (nil for none), and one taking only the fields (using nil for
|
|
rlm@10
|
289 meta and extension fields)."
|
|
rlm@10
|
290 {:added "1.2"}
|
|
rlm@10
|
291
|
|
rlm@10
|
292 [name [& fields] & opts+specs]
|
|
rlm@10
|
293 (let [gname name
|
|
rlm@10
|
294 [interfaces methods opts] (parse-opts+specs opts+specs)
|
|
rlm@10
|
295 classname (symbol (str *ns* "." gname))
|
|
rlm@10
|
296 tag (keyword (str *ns*) (str name))
|
|
rlm@10
|
297 hinted-fields fields
|
|
rlm@10
|
298 fields (vec (map #(with-meta % nil) fields))]
|
|
rlm@10
|
299 `(let []
|
|
rlm@10
|
300 ~(emit-defrecord name gname (vec hinted-fields) (vec interfaces) methods)
|
|
rlm@10
|
301 (defmethod print-method ~classname [o# w#]
|
|
rlm@10
|
302 ((var print-defrecord) o# w#))
|
|
rlm@10
|
303 (import ~classname)
|
|
rlm@10
|
304 #_(defn ~name
|
|
rlm@10
|
305 ([~@fields] (new ~classname ~@fields nil nil))
|
|
rlm@10
|
306 ([~@fields meta# extmap#] (new ~classname ~@fields meta# extmap#))))))
|
|
rlm@10
|
307
|
|
rlm@10
|
308 (defn- print-defrecord [o ^Writer w]
|
|
rlm@10
|
309 (print-meta o w)
|
|
rlm@10
|
310 (.write w "#:")
|
|
rlm@10
|
311 (.write w (.getName (class o)))
|
|
rlm@10
|
312 (print-map
|
|
rlm@10
|
313 o
|
|
rlm@10
|
314 pr-on w))
|
|
rlm@10
|
315
|
|
rlm@10
|
316 (defn- emit-deftype*
|
|
rlm@10
|
317 "Do not use this directly - use deftype"
|
|
rlm@10
|
318 [tagname name fields interfaces methods]
|
|
rlm@10
|
319 (let [classname (with-meta (symbol (str *ns* "." name)) (meta name))]
|
|
rlm@10
|
320 `(deftype* ~tagname ~classname ~fields
|
|
rlm@10
|
321 :implements ~interfaces
|
|
rlm@10
|
322 ~@methods)))
|
|
rlm@10
|
323
|
|
rlm@10
|
324 (defmacro deftype
|
|
rlm@10
|
325 "Alpha - subject to change
|
|
rlm@10
|
326
|
|
rlm@10
|
327 (deftype name [fields*] options* specs*)
|
|
rlm@10
|
328
|
|
rlm@10
|
329 Currently there are no options.
|
|
rlm@10
|
330
|
|
rlm@10
|
331 Each spec consists of a protocol or interface name followed by zero
|
|
rlm@10
|
332 or more method bodies:
|
|
rlm@10
|
333
|
|
rlm@10
|
334 protocol-or-interface-or-Object
|
|
rlm@10
|
335 (methodName [args*] body)*
|
|
rlm@10
|
336
|
|
rlm@10
|
337 Dynamically generates compiled bytecode for class with the given
|
|
rlm@10
|
338 name, in a package with the same name as the current namespace, the
|
|
rlm@10
|
339 given fields, and, optionally, methods for protocols and/or
|
|
rlm@10
|
340 interfaces.
|
|
rlm@10
|
341
|
|
rlm@10
|
342 The class will have the (by default, immutable) fields named by
|
|
rlm@10
|
343 fields, which can have type hints. Protocols/interfaces and methods
|
|
rlm@10
|
344 are optional. The only methods that can be supplied are those
|
|
rlm@10
|
345 declared in the protocols/interfaces. Note that method bodies are
|
|
rlm@10
|
346 not closures, the local environment includes only the named fields,
|
|
rlm@10
|
347 and those fields can be accessed directy. Fields can be qualified
|
|
rlm@10
|
348 with the metadata :volatile-mutable true or :unsynchronized-mutable
|
|
rlm@10
|
349 true, at which point (set! afield aval) will be supported in method
|
|
rlm@10
|
350 bodies. Note well that mutable fields are extremely difficult to use
|
|
rlm@10
|
351 correctly, and are present only to facilitate the building of higher
|
|
rlm@10
|
352 level constructs, such as Clojure's reference types, in Clojure
|
|
rlm@10
|
353 itself. They are for experts only - if the semantics and
|
|
rlm@10
|
354 implications of :volatile-mutable or :unsynchronized-mutable are not
|
|
rlm@10
|
355 immediately apparent to you, you should not be using them.
|
|
rlm@10
|
356
|
|
rlm@10
|
357 Method definitions take the form:
|
|
rlm@10
|
358
|
|
rlm@10
|
359 (methodname [args*] body)
|
|
rlm@10
|
360
|
|
rlm@10
|
361 The argument and return types can be hinted on the arg and
|
|
rlm@10
|
362 methodname symbols. If not supplied, they will be inferred, so type
|
|
rlm@10
|
363 hints should be reserved for disambiguation.
|
|
rlm@10
|
364
|
|
rlm@10
|
365 Methods should be supplied for all methods of the desired
|
|
rlm@10
|
366 protocol(s) and interface(s). You can also define overrides for
|
|
rlm@10
|
367 methods of Object. Note that a parameter must be supplied to
|
|
rlm@10
|
368 correspond to the target object ('this' in Java parlance). Thus
|
|
rlm@10
|
369 methods for interfaces will take one more argument than do the
|
|
rlm@10
|
370 interface declarations. Note also that recur calls to the method
|
|
rlm@10
|
371 head should *not* pass the target object, it will be supplied
|
|
rlm@10
|
372 automatically and can not be substituted.
|
|
rlm@10
|
373
|
|
rlm@10
|
374 In the method bodies, the (unqualified) name can be used to name the
|
|
rlm@10
|
375 class (for calls to new, instance? etc).
|
|
rlm@10
|
376
|
|
rlm@10
|
377 When AOT compiling, generates compiled bytecode for a class with the
|
|
rlm@10
|
378 given name (a symbol), prepends the current ns as the package, and
|
|
rlm@10
|
379 writes the .class file to the *compile-path* directory.
|
|
rlm@10
|
380
|
|
rlm@10
|
381 One constructors will be defined, taking the designated fields."
|
|
rlm@10
|
382 {:added "1.2"}
|
|
rlm@10
|
383
|
|
rlm@10
|
384 [name [& fields] & opts+specs]
|
|
rlm@10
|
385 (let [gname name
|
|
rlm@10
|
386 [interfaces methods opts] (parse-opts+specs opts+specs)
|
|
rlm@10
|
387 classname (symbol (str *ns* "." gname))
|
|
rlm@10
|
388 tag (keyword (str *ns*) (str name))
|
|
rlm@10
|
389 hinted-fields fields
|
|
rlm@10
|
390 fields (vec (map #(with-meta % nil) fields))]
|
|
rlm@10
|
391 `(let []
|
|
rlm@10
|
392 ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods)
|
|
rlm@10
|
393 (import ~classname))))
|
|
rlm@10
|
394
|
|
rlm@10
|
395
|
|
rlm@10
|
396
|
|
rlm@10
|
397
|
|
rlm@10
|
398 ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;;
|
|
rlm@10
|
399
|
|
rlm@10
|
400 (defn- expand-method-impl-cache [^clojure.lang.MethodImplCache cache c f]
|
|
rlm@10
|
401 (let [cs (into {} (remove (fn [[c e]] (nil? e)) (map vec (partition 2 (.table cache)))))
|
|
rlm@10
|
402 cs (assoc cs c (clojure.lang.MethodImplCache$Entry. c f))
|
|
rlm@10
|
403 [shift mask] (min-hash (keys cs))
|
|
rlm@10
|
404 table (make-array Object (* 2 (inc mask)))
|
|
rlm@10
|
405 table (reduce (fn [^objects t [c e]]
|
|
rlm@10
|
406 (let [i (* 2 (int (shift-mask shift mask (hash c))))]
|
|
rlm@10
|
407 (aset t i c)
|
|
rlm@10
|
408 (aset t (inc i) e)
|
|
rlm@10
|
409 t))
|
|
rlm@10
|
410 table cs)]
|
|
rlm@10
|
411 (clojure.lang.MethodImplCache. (.protocol cache) (.methodk cache) shift mask table)))
|
|
rlm@10
|
412
|
|
rlm@10
|
413 (defn- super-chain [^Class c]
|
|
rlm@10
|
414 (when c
|
|
rlm@10
|
415 (cons c (super-chain (.getSuperclass c)))))
|
|
rlm@10
|
416
|
|
rlm@10
|
417 (defn- pref
|
|
rlm@10
|
418 ([] nil)
|
|
rlm@10
|
419 ([a] a)
|
|
rlm@10
|
420 ([^Class a ^Class b]
|
|
rlm@10
|
421 (if (.isAssignableFrom a b) b a)))
|
|
rlm@10
|
422
|
|
rlm@10
|
423 (defn find-protocol-impl [protocol x]
|
|
rlm@10
|
424 (if (instance? (:on-interface protocol) x)
|
|
rlm@10
|
425 x
|
|
rlm@10
|
426 (let [c (class x)
|
|
rlm@10
|
427 impl #(get (:impls protocol) %)]
|
|
rlm@10
|
428 (or (impl c)
|
|
rlm@10
|
429 (and c (or (first (remove nil? (map impl (butlast (super-chain c)))))
|
|
rlm@10
|
430 (when-let [t (reduce pref (filter impl (disj (supers c) Object)))]
|
|
rlm@10
|
431 (impl t))
|
|
rlm@10
|
432 (impl Object)))))))
|
|
rlm@10
|
433
|
|
rlm@10
|
434 (defn find-protocol-method [protocol methodk x]
|
|
rlm@10
|
435 (get (find-protocol-impl protocol x) methodk))
|
|
rlm@10
|
436
|
|
rlm@10
|
437 (defn- protocol?
|
|
rlm@10
|
438 [maybe-p]
|
|
rlm@10
|
439 (boolean (:on-interface maybe-p)))
|
|
rlm@10
|
440
|
|
rlm@10
|
441 (defn- implements? [protocol atype]
|
|
rlm@10
|
442 (and atype (.isAssignableFrom ^Class (:on-interface protocol) atype)))
|
|
rlm@10
|
443
|
|
rlm@10
|
444 (defn extends?
|
|
rlm@10
|
445 "Returns true if atype extends protocol"
|
|
rlm@10
|
446 {:added "1.2"}
|
|
rlm@10
|
447 [protocol atype]
|
|
rlm@10
|
448 (boolean (or (implements? protocol atype)
|
|
rlm@10
|
449 (get (:impls protocol) atype))))
|
|
rlm@10
|
450
|
|
rlm@10
|
451 (defn extenders
|
|
rlm@10
|
452 "Returns a collection of the types explicitly extending protocol"
|
|
rlm@10
|
453 {:added "1.2"}
|
|
rlm@10
|
454 [protocol]
|
|
rlm@10
|
455 (keys (:impls protocol)))
|
|
rlm@10
|
456
|
|
rlm@10
|
457 (defn satisfies?
|
|
rlm@10
|
458 "Returns true if x satisfies the protocol"
|
|
rlm@10
|
459 {:added "1.2"}
|
|
rlm@10
|
460 [protocol x]
|
|
rlm@10
|
461 (boolean (find-protocol-impl protocol x)))
|
|
rlm@10
|
462
|
|
rlm@10
|
463 (defn -cache-protocol-fn [^clojure.lang.AFunction pf x ^Class c ^clojure.lang.IFn interf]
|
|
rlm@10
|
464 (let [cache (.__methodImplCache pf)
|
|
rlm@10
|
465 f (if (.isInstance c x)
|
|
rlm@10
|
466 interf
|
|
rlm@10
|
467 (find-protocol-method (.protocol cache) (.methodk cache) x))]
|
|
rlm@10
|
468 (when-not f
|
|
rlm@10
|
469 (throw (IllegalArgumentException. (str "No implementation of method: " (.methodk cache)
|
|
rlm@10
|
470 " of protocol: " (:var (.protocol cache))
|
|
rlm@10
|
471 " found for class: " (if (nil? x) "nil" (.getName (class x)))))))
|
|
rlm@10
|
472 (set! (.__methodImplCache pf) (expand-method-impl-cache cache (class x) f))
|
|
rlm@10
|
473 f))
|
|
rlm@10
|
474
|
|
rlm@10
|
475 (defn- emit-method-builder [on-interface method on-method arglists]
|
|
rlm@10
|
476 (let [methodk (keyword method)
|
|
rlm@10
|
477 gthis (with-meta (gensym) {:tag 'clojure.lang.AFunction})
|
|
rlm@10
|
478 ginterf (gensym)]
|
|
rlm@10
|
479 `(fn [cache#]
|
|
rlm@10
|
480 (let [~ginterf
|
|
rlm@10
|
481 (fn
|
|
rlm@10
|
482 ~@(map
|
|
rlm@10
|
483 (fn [args]
|
|
rlm@10
|
484 (let [gargs (map #(gensym (str "gf__" % "__")) args)
|
|
rlm@10
|
485 target (first gargs)]
|
|
rlm@10
|
486 `([~@gargs]
|
|
rlm@10
|
487 (. ~(with-meta target {:tag on-interface}) ~(or on-method method) ~@(rest gargs)))))
|
|
rlm@10
|
488 arglists))
|
|
rlm@10
|
489 ^clojure.lang.AFunction f#
|
|
rlm@10
|
490 (fn ~gthis
|
|
rlm@10
|
491 ~@(map
|
|
rlm@10
|
492 (fn [args]
|
|
rlm@10
|
493 (let [gargs (map #(gensym (str "gf__" % "__")) args)
|
|
rlm@10
|
494 target (first gargs)]
|
|
rlm@10
|
495 `([~@gargs]
|
|
rlm@10
|
496 (let [cache# (.__methodImplCache ~gthis)
|
|
rlm@10
|
497 f# (.fnFor cache# (clojure.lang.Util/classOf ~target))]
|
|
rlm@10
|
498 (if f#
|
|
rlm@10
|
499 (f# ~@gargs)
|
|
rlm@10
|
500 ((-cache-protocol-fn ~gthis ~target ~on-interface ~ginterf) ~@gargs))))))
|
|
rlm@10
|
501 arglists))]
|
|
rlm@10
|
502 (set! (.__methodImplCache f#) cache#)
|
|
rlm@10
|
503 f#))))
|
|
rlm@10
|
504
|
|
rlm@10
|
505 (defn -reset-methods [protocol]
|
|
rlm@10
|
506 (doseq [[^clojure.lang.Var v build] (:method-builders protocol)]
|
|
rlm@10
|
507 (let [cache (clojure.lang.MethodImplCache. protocol (keyword (.sym v)))]
|
|
rlm@10
|
508 (.bindRoot v (build cache)))))
|
|
rlm@10
|
509
|
|
rlm@10
|
510 (defn- assert-same-protocol [protocol-var method-syms]
|
|
rlm@10
|
511 (doseq [m method-syms]
|
|
rlm@10
|
512 (let [v (resolve m)
|
|
rlm@10
|
513 p (:protocol (meta v))]
|
|
rlm@10
|
514 (when (and v (bound? v) (not= protocol-var p))
|
|
rlm@10
|
515 (binding [*out* *err*]
|
|
rlm@10
|
516 (println "Warning: protocol" protocol-var "is overwriting"
|
|
rlm@10
|
517 (if p
|
|
rlm@10
|
518 (str "method " (.sym v) " of protocol " (.sym p))
|
|
rlm@10
|
519 (str "function " (.sym v)))))))))
|
|
rlm@10
|
520
|
|
rlm@10
|
521 (defn- emit-protocol [name opts+sigs]
|
|
rlm@10
|
522 (let [iname (symbol (str (munge *ns*) "." (munge name)))
|
|
rlm@10
|
523 [opts sigs]
|
|
rlm@10
|
524 (loop [opts {:on (list 'quote iname) :on-interface iname} sigs opts+sigs]
|
|
rlm@10
|
525 (condp #(%1 %2) (first sigs)
|
|
rlm@10
|
526 string? (recur (assoc opts :doc (first sigs)) (next sigs))
|
|
rlm@10
|
527 keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs))
|
|
rlm@10
|
528 [opts sigs]))
|
|
rlm@10
|
529 sigs (reduce (fn [m s]
|
|
rlm@10
|
530 (let [name-meta (meta (first s))
|
|
rlm@10
|
531 mname (with-meta (first s) nil)
|
|
rlm@10
|
532 [arglists doc]
|
|
rlm@10
|
533 (loop [as [] rs (rest s)]
|
|
rlm@10
|
534 (if (vector? (first rs))
|
|
rlm@10
|
535 (recur (conj as (first rs)) (next rs))
|
|
rlm@10
|
536 [(seq as) (first rs)]))]
|
|
rlm@10
|
537 (when (some #{0} (map count arglists))
|
|
rlm@10
|
538 (throw (IllegalArgumentException. (str "Protocol fn: " mname " must take at least one arg"))))
|
|
rlm@10
|
539 (assoc m (keyword mname)
|
|
rlm@10
|
540 (merge name-meta
|
|
rlm@10
|
541 {:name (vary-meta mname assoc :doc doc :arglists arglists)
|
|
rlm@10
|
542 :arglists arglists
|
|
rlm@10
|
543 :doc doc}))))
|
|
rlm@10
|
544 {} sigs)
|
|
rlm@10
|
545 meths (mapcat (fn [sig]
|
|
rlm@10
|
546 (let [m (munge (:name sig))]
|
|
rlm@10
|
547 (map #(vector m (vec (repeat (dec (count %))'Object)) 'Object)
|
|
rlm@10
|
548 (:arglists sig))))
|
|
rlm@10
|
549 (vals sigs))]
|
|
rlm@10
|
550 `(do
|
|
rlm@10
|
551 (defonce ~name {})
|
|
rlm@10
|
552 (gen-interface :name ~iname :methods ~meths)
|
|
rlm@10
|
553 (alter-meta! (var ~name) assoc :doc ~(:doc opts))
|
|
rlm@10
|
554 (#'assert-same-protocol (var ~name) '~(map :name (vals sigs)))
|
|
rlm@10
|
555 (alter-var-root (var ~name) merge
|
|
rlm@10
|
556 (assoc ~opts
|
|
rlm@10
|
557 :sigs '~sigs
|
|
rlm@10
|
558 :var (var ~name)
|
|
rlm@10
|
559 :method-map
|
|
rlm@10
|
560 ~(and (:on opts)
|
|
rlm@10
|
561 (apply hash-map
|
|
rlm@10
|
562 (mapcat
|
|
rlm@10
|
563 (fn [s]
|
|
rlm@10
|
564 [(keyword (:name s)) (keyword (or (:on s) (:name s)))])
|
|
rlm@10
|
565 (vals sigs))))
|
|
rlm@10
|
566 :method-builders
|
|
rlm@10
|
567 ~(apply hash-map
|
|
rlm@10
|
568 (mapcat
|
|
rlm@10
|
569 (fn [s]
|
|
rlm@10
|
570 [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)})))
|
|
rlm@10
|
571 (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))])
|
|
rlm@10
|
572 (vals sigs)))))
|
|
rlm@10
|
573 (-reset-methods ~name)
|
|
rlm@10
|
574 '~name)))
|
|
rlm@10
|
575
|
|
rlm@10
|
576 (defmacro defprotocol
|
|
rlm@10
|
577 "A protocol is a named set of named methods and their signatures:
|
|
rlm@10
|
578 (defprotocol AProtocolName
|
|
rlm@10
|
579
|
|
rlm@10
|
580 ;optional doc string
|
|
rlm@10
|
581 \"A doc string for AProtocol abstraction\"
|
|
rlm@10
|
582
|
|
rlm@10
|
583 ;method signatures
|
|
rlm@10
|
584 (bar [this a b] \"bar docs\")
|
|
rlm@10
|
585 (baz [this a] [this a b] [this a b c] \"baz docs\"))
|
|
rlm@10
|
586
|
|
rlm@10
|
587 No implementations are provided. Docs can be specified for the
|
|
rlm@10
|
588 protocol overall and for each method. The above yields a set of
|
|
rlm@10
|
589 polymorphic functions and a protocol object. All are
|
|
rlm@10
|
590 namespace-qualified by the ns enclosing the definition The resulting
|
|
rlm@10
|
591 functions dispatch on the type of their first argument, which is
|
|
rlm@10
|
592 required and corresponds to the implicit target object ('this' in
|
|
rlm@10
|
593 Java parlance). defprotocol is dynamic, has no special compile-time
|
|
rlm@10
|
594 effect, and defines no new types or classes. Implementations of
|
|
rlm@10
|
595 the protocol methods can be provided using extend.
|
|
rlm@10
|
596
|
|
rlm@10
|
597 defprotocol will automatically generate a corresponding interface,
|
|
rlm@10
|
598 with the same name as the protocol, i.e. given a protocol:
|
|
rlm@10
|
599 my.ns/Protocol, an interface: my.ns.Protocol. The interface will
|
|
rlm@10
|
600 have methods corresponding to the protocol functions, and the
|
|
rlm@10
|
601 protocol will automatically work with instances of the interface.
|
|
rlm@10
|
602
|
|
rlm@10
|
603 Note that you should not use this interface with deftype or
|
|
rlm@10
|
604 reify, as they support the protocol directly:
|
|
rlm@10
|
605
|
|
rlm@10
|
606 (defprotocol P
|
|
rlm@10
|
607 (foo [this])
|
|
rlm@10
|
608 (bar-me [this] [this y]))
|
|
rlm@10
|
609
|
|
rlm@10
|
610 (deftype Foo [a b c]
|
|
rlm@10
|
611 P
|
|
rlm@10
|
612 (foo [this] a)
|
|
rlm@10
|
613 (bar-me [this] b)
|
|
rlm@10
|
614 (bar-me [this y] (+ c y)))
|
|
rlm@10
|
615
|
|
rlm@10
|
616 (bar-me (Foo. 1 2 3) 42)
|
|
rlm@10
|
617 => 45
|
|
rlm@10
|
618
|
|
rlm@10
|
619 (foo
|
|
rlm@10
|
620 (let [x 42]
|
|
rlm@10
|
621 (reify P
|
|
rlm@10
|
622 (foo [this] 17)
|
|
rlm@10
|
623 (bar-me [this] x)
|
|
rlm@10
|
624 (bar-me [this y] x))))
|
|
rlm@10
|
625 => 17"
|
|
rlm@10
|
626 {:added "1.2"}
|
|
rlm@10
|
627 [name & opts+sigs]
|
|
rlm@10
|
628 (emit-protocol name opts+sigs))
|
|
rlm@10
|
629
|
|
rlm@10
|
630 (defn extend
|
|
rlm@10
|
631 "Implementations of protocol methods can be provided using the extend construct:
|
|
rlm@10
|
632
|
|
rlm@10
|
633 (extend AType
|
|
rlm@10
|
634 AProtocol
|
|
rlm@10
|
635 {:foo an-existing-fn
|
|
rlm@10
|
636 :bar (fn [a b] ...)
|
|
rlm@10
|
637 :baz (fn ([a]...) ([a b] ...)...)}
|
|
rlm@10
|
638 BProtocol
|
|
rlm@10
|
639 {...}
|
|
rlm@10
|
640 ...)
|
|
rlm@10
|
641
|
|
rlm@10
|
642 extend takes a type/class (or interface, see below), and one or more
|
|
rlm@10
|
643 protocol + method map pairs. It will extend the polymorphism of the
|
|
rlm@10
|
644 protocol's methods to call the supplied methods when an AType is
|
|
rlm@10
|
645 provided as the first argument.
|
|
rlm@10
|
646
|
|
rlm@10
|
647 Method maps are maps of the keyword-ized method names to ordinary
|
|
rlm@10
|
648 fns. This facilitates easy reuse of existing fns and fn maps, for
|
|
rlm@10
|
649 code reuse/mixins without derivation or composition. You can extend
|
|
rlm@10
|
650 an interface to a protocol. This is primarily to facilitate interop
|
|
rlm@10
|
651 with the host (e.g. Java) but opens the door to incidental multiple
|
|
rlm@10
|
652 inheritance of implementation since a class can inherit from more
|
|
rlm@10
|
653 than one interface, both of which extend the protocol. It is TBD how
|
|
rlm@10
|
654 to specify which impl to use. You can extend a protocol on nil.
|
|
rlm@10
|
655
|
|
rlm@10
|
656 If you are supplying the definitions explicitly (i.e. not reusing
|
|
rlm@10
|
657 exsting functions or mixin maps), you may find it more convenient to
|
|
rlm@10
|
658 use the extend-type or extend-protocol macros.
|
|
rlm@10
|
659
|
|
rlm@10
|
660 Note that multiple independent extend clauses can exist for the same
|
|
rlm@10
|
661 type, not all protocols need be defined in a single extend call.
|
|
rlm@10
|
662
|
|
rlm@10
|
663 See also:
|
|
rlm@10
|
664 extends?, satisfies?, extenders"
|
|
rlm@10
|
665 {:added "1.2"}
|
|
rlm@10
|
666 [atype & proto+mmaps]
|
|
rlm@10
|
667 (doseq [[proto mmap] (partition 2 proto+mmaps)]
|
|
rlm@10
|
668 (when-not (protocol? proto)
|
|
rlm@10
|
669 (throw (IllegalArgumentException.
|
|
rlm@10
|
670 (str proto " is not a protocol"))))
|
|
rlm@10
|
671 (when (implements? proto atype)
|
|
rlm@10
|
672 (throw (IllegalArgumentException.
|
|
rlm@10
|
673 (str atype " already directly implements " (:on-interface proto) " for protocol:"
|
|
rlm@10
|
674 (:var proto)))))
|
|
rlm@10
|
675 (-reset-methods (alter-var-root (:var proto) assoc-in [:impls atype] mmap))))
|
|
rlm@10
|
676
|
|
rlm@10
|
677 (defn- emit-impl [[p fs]]
|
|
rlm@10
|
678 [p (zipmap (map #(-> % first keyword) fs)
|
|
rlm@10
|
679 (map #(cons 'fn (drop 1 %)) fs))])
|
|
rlm@10
|
680
|
|
rlm@10
|
681 (defn- emit-hinted-impl [c [p fs]]
|
|
rlm@10
|
682 (let [hint (fn [specs]
|
|
rlm@10
|
683 (let [specs (if (vector? (first specs))
|
|
rlm@10
|
684 (list specs)
|
|
rlm@10
|
685 specs)]
|
|
rlm@10
|
686 (map (fn [[[target & args] & body]]
|
|
rlm@10
|
687 (cons (apply vector (vary-meta target assoc :tag c) args)
|
|
rlm@10
|
688 body))
|
|
rlm@10
|
689 specs)))]
|
|
rlm@10
|
690 [p (zipmap (map #(-> % first keyword) fs)
|
|
rlm@10
|
691 (map #(cons 'fn (hint (drop 1 %))) fs))]))
|
|
rlm@10
|
692
|
|
rlm@10
|
693 (defn- emit-extend-type [c specs]
|
|
rlm@10
|
694 (let [impls (parse-impls specs)]
|
|
rlm@10
|
695 `(extend ~c
|
|
rlm@10
|
696 ~@(mapcat (partial emit-hinted-impl c) impls))))
|
|
rlm@10
|
697
|
|
rlm@10
|
698 (defmacro extend-type
|
|
rlm@10
|
699 "A macro that expands into an extend call. Useful when you are
|
|
rlm@10
|
700 supplying the definitions explicitly inline, extend-type
|
|
rlm@10
|
701 automatically creates the maps required by extend. Propagates the
|
|
rlm@10
|
702 class as a type hint on the first argument of all fns.
|
|
rlm@10
|
703
|
|
rlm@10
|
704 (extend-type MyType
|
|
rlm@10
|
705 Countable
|
|
rlm@10
|
706 (cnt [c] ...)
|
|
rlm@10
|
707 Foo
|
|
rlm@10
|
708 (bar [x y] ...)
|
|
rlm@10
|
709 (baz ([x] ...) ([x y & zs] ...)))
|
|
rlm@10
|
710
|
|
rlm@10
|
711 expands into:
|
|
rlm@10
|
712
|
|
rlm@10
|
713 (extend MyType
|
|
rlm@10
|
714 Countable
|
|
rlm@10
|
715 {:cnt (fn [c] ...)}
|
|
rlm@10
|
716 Foo
|
|
rlm@10
|
717 {:baz (fn ([x] ...) ([x y & zs] ...))
|
|
rlm@10
|
718 :bar (fn [x y] ...)})"
|
|
rlm@10
|
719 {:added "1.2"}
|
|
rlm@10
|
720 [t & specs]
|
|
rlm@10
|
721 (emit-extend-type t specs))
|
|
rlm@10
|
722
|
|
rlm@10
|
723 (defn- emit-extend-protocol [p specs]
|
|
rlm@10
|
724 (let [impls (parse-impls specs)]
|
|
rlm@10
|
725 `(do
|
|
rlm@10
|
726 ~@(map (fn [[t fs]]
|
|
rlm@10
|
727 `(extend-type ~t ~p ~@fs))
|
|
rlm@10
|
728 impls))))
|
|
rlm@10
|
729
|
|
rlm@10
|
730 (defmacro extend-protocol
|
|
rlm@10
|
731 "Useful when you want to provide several implementations of the same
|
|
rlm@10
|
732 protocol all at once. Takes a single protocol and the implementation
|
|
rlm@10
|
733 of that protocol for one or more types. Expands into calls to
|
|
rlm@10
|
734 extend-type:
|
|
rlm@10
|
735
|
|
rlm@10
|
736 (extend-protocol Protocol
|
|
rlm@10
|
737 AType
|
|
rlm@10
|
738 (foo [x] ...)
|
|
rlm@10
|
739 (bar [x y] ...)
|
|
rlm@10
|
740 BType
|
|
rlm@10
|
741 (foo [x] ...)
|
|
rlm@10
|
742 (bar [x y] ...)
|
|
rlm@10
|
743 AClass
|
|
rlm@10
|
744 (foo [x] ...)
|
|
rlm@10
|
745 (bar [x y] ...)
|
|
rlm@10
|
746 nil
|
|
rlm@10
|
747 (foo [x] ...)
|
|
rlm@10
|
748 (bar [x y] ...))
|
|
rlm@10
|
749
|
|
rlm@10
|
750 expands into:
|
|
rlm@10
|
751
|
|
rlm@10
|
752 (do
|
|
rlm@10
|
753 (clojure.core/extend-type AType Protocol
|
|
rlm@10
|
754 (foo [x] ...)
|
|
rlm@10
|
755 (bar [x y] ...))
|
|
rlm@10
|
756 (clojure.core/extend-type BType Protocol
|
|
rlm@10
|
757 (foo [x] ...)
|
|
rlm@10
|
758 (bar [x y] ...))
|
|
rlm@10
|
759 (clojure.core/extend-type AClass Protocol
|
|
rlm@10
|
760 (foo [x] ...)
|
|
rlm@10
|
761 (bar [x y] ...))
|
|
rlm@10
|
762 (clojure.core/extend-type nil Protocol
|
|
rlm@10
|
763 (foo [x] ...)
|
|
rlm@10
|
764 (bar [x y] ...)))"
|
|
rlm@10
|
765 {:added "1.2"}
|
|
rlm@10
|
766
|
|
rlm@10
|
767 [p & specs]
|
|
rlm@10
|
768 (emit-extend-protocol p specs))
|
|
rlm@10
|
769
|
