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