Mercurial > lasercutter
view 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 |
line wrap: on
line source
1 ; Copyright (c) Rich Hickey. All rights reserved.2 ; The use and distribution terms for this software are covered by the3 ; 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 by6 ; the terms of this license.7 ; You must not remove this notice, or any other, from this software.9 (in-ns 'clojure.core)11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; definterface ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;13 (defn namespace-munge14 "Convert a Clojure namespace name to a legal Java package name."15 {:added "1.2"}16 [ns]17 (.replace (str ns) \- \_))19 ;for now, built on gen-interface20 (defmacro definterface21 [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))))30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; reify/deftype ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;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])))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)))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 set53 (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]))62 (defmacro reify63 "reify is a macro with the following structure:65 (reify options* specs*)67 Currently there are no options.69 Each spec consists of the protocol or interface name followed by zero70 or more method bodies:72 protocol-or-interface-or-Object73 (methodName [args+] body)*75 Methods should be supplied for all methods of the desired76 protocol(s) and interface(s). You can also define overrides for77 methods of Object. Note that the first parameter must be supplied to78 correspond to the target object ('this' in Java parlance). Thus79 methods for interfaces will take one more argument than do the80 interface declarations. Note also that recur calls to the method81 head should *not* pass the target object, it will be supplied82 automatically and can not be substituted.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 you86 leave out all hints, reify will try to match on same name/arity87 method in the protocol(s)/interface(s) - this is preferred. If you88 supply any hints at all, no inference is done, so all hints (or89 default of Object) must be correct, for both arguments and return90 type. If a method is overloaded in a protocol/interface, multiple91 independent method definitions must be supplied. If overloaded with92 same arity in an interface you must specify complete hints to93 disambiguate - a missing hint implies Object.95 recur works to method heads The method bodies of reify are lexical96 closures, and can refer to the surrounding local scope:98 (str (let [f \"foo\"]99 (reify Object100 (toString [this] f))))101 == \"foo\"103 (seq (let [f \"foo\"]104 (reify clojure.lang.Seqable105 (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))))112 (defn hash-combine [x y]113 (clojure.lang.Util/hashCombine x (clojure.lang.Util/hash y)))115 (defn munge [s]116 ((if (symbol? s) symbol str) (clojure.lang.Compiler/munge (str s))))118 (defn- imap-cons119 [^IPersistentMap this o]120 (cond121 (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 this128 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))))134 (defn- emit-defrecord135 "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 fields144 fields (vec (map #(with-meta % nil) fields))145 base-fields fields146 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 (letfn151 [(eqhash [[i m]]152 [i153 (conj m154 `(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 (mapcat172 (fn [fld]173 [(keyword fld)174 `(reify clojure.lang.ILookupThunk175 (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 m184 `(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 (boolean189 (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 m213 `(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))))))230 (defmacro defrecord231 "Alpha - subject to change233 (defrecord name [fields*] options* specs*)235 Currently there are no options.237 Each spec consists of a protocol or interface name followed by zero238 or more method bodies:240 protocol-or-interface-or-Object241 (methodName [args*] body)*243 Dynamically generates compiled bytecode for class with the given244 name, in a package with the same name as the current namespace, the245 given fields, and, optionally, methods for protocols and/or246 interfaces.248 The class will have the (immutable) fields named by249 fields, which can have type hints. Protocols/interfaces and methods250 are optional. The only methods that can be supplied are those251 declared in the protocols/interfaces. Note that method bodies are252 not closures, the local environment includes only the named fields,253 and those fields can be accessed directy.255 Method definitions take the form:257 (methodname [args*] body)259 The argument and return types can be hinted on the arg and260 methodname symbols. If not supplied, they will be inferred, so type261 hints should be reserved for disambiguation.263 Methods should be supplied for all methods of the desired264 protocol(s) and interface(s). You can also define overrides for265 methods of Object. Note that a parameter must be supplied to266 correspond to the target object ('this' in Java parlance). Thus267 methods for interfaces will take one more argument than do the268 interface declarations. Note also that recur calls to the method269 head should *not* pass the target object, it will be supplied270 automatically and can not be substituted.272 In the method bodies, the (unqualified) name can be used to name the273 class (for calls to new, instance? etc).275 The class will have implementations of several (clojure.lang)276 interfaces generated automatically: IObj (metadata support) and277 IPersistentMap, and all of their superinterfaces.279 In addition, defrecord will define type-and-value-based equality and280 hashCode.282 When AOT compiling, generates compiled bytecode for a class with the283 given name (a symbol), prepends the current ns as the package, and284 writes the .class file to the *compile-path* directory.286 Two constructors will be defined, one taking the designated fields287 followed by a metadata map (nil for none) and an extension field288 map (nil for none), and one taking only the fields (using nil for289 meta and extension fields)."290 {:added "1.2"}292 [name [& fields] & opts+specs]293 (let [gname name294 [interfaces methods opts] (parse-opts+specs opts+specs)295 classname (symbol (str *ns* "." gname))296 tag (keyword (str *ns*) (str name))297 hinted-fields fields298 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 ~name305 ([~@fields] (new ~classname ~@fields nil nil))306 ([~@fields meta# extmap#] (new ~classname ~@fields meta# extmap#))))))308 (defn- print-defrecord [o ^Writer w]309 (print-meta o w)310 (.write w "#:")311 (.write w (.getName (class o)))312 (print-map313 o314 pr-on w))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 ~fields321 :implements ~interfaces322 ~@methods)))324 (defmacro deftype325 "Alpha - subject to change327 (deftype name [fields*] options* specs*)329 Currently there are no options.331 Each spec consists of a protocol or interface name followed by zero332 or more method bodies:334 protocol-or-interface-or-Object335 (methodName [args*] body)*337 Dynamically generates compiled bytecode for class with the given338 name, in a package with the same name as the current namespace, the339 given fields, and, optionally, methods for protocols and/or340 interfaces.342 The class will have the (by default, immutable) fields named by343 fields, which can have type hints. Protocols/interfaces and methods344 are optional. The only methods that can be supplied are those345 declared in the protocols/interfaces. Note that method bodies are346 not closures, the local environment includes only the named fields,347 and those fields can be accessed directy. Fields can be qualified348 with the metadata :volatile-mutable true or :unsynchronized-mutable349 true, at which point (set! afield aval) will be supported in method350 bodies. Note well that mutable fields are extremely difficult to use351 correctly, and are present only to facilitate the building of higher352 level constructs, such as Clojure's reference types, in Clojure353 itself. They are for experts only - if the semantics and354 implications of :volatile-mutable or :unsynchronized-mutable are not355 immediately apparent to you, you should not be using them.357 Method definitions take the form:359 (methodname [args*] body)361 The argument and return types can be hinted on the arg and362 methodname symbols. If not supplied, they will be inferred, so type363 hints should be reserved for disambiguation.365 Methods should be supplied for all methods of the desired366 protocol(s) and interface(s). You can also define overrides for367 methods of Object. Note that a parameter must be supplied to368 correspond to the target object ('this' in Java parlance). Thus369 methods for interfaces will take one more argument than do the370 interface declarations. Note also that recur calls to the method371 head should *not* pass the target object, it will be supplied372 automatically and can not be substituted.374 In the method bodies, the (unqualified) name can be used to name the375 class (for calls to new, instance? etc).377 When AOT compiling, generates compiled bytecode for a class with the378 given name (a symbol), prepends the current ns as the package, and379 writes the .class file to the *compile-path* directory.381 One constructors will be defined, taking the designated fields."382 {:added "1.2"}384 [name [& fields] & opts+specs]385 (let [gname name386 [interfaces methods opts] (parse-opts+specs opts+specs)387 classname (symbol (str *ns* "." gname))388 tag (keyword (str *ns*) (str name))389 hinted-fields fields390 fields (vec (map #(with-meta % nil) fields))]391 `(let []392 ~(emit-deftype* name gname (vec hinted-fields) (vec interfaces) methods)393 (import ~classname))))398 ;;;;;;;;;;;;;;;;;;;;;;; protocols ;;;;;;;;;;;;;;;;;;;;;;;;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)))413 (defn- super-chain [^Class c]414 (when c415 (cons c (super-chain (.getSuperclass c)))))417 (defn- pref418 ([] nil)419 ([a] a)420 ([^Class a ^Class b]421 (if (.isAssignableFrom a b) b a)))423 (defn find-protocol-impl [protocol x]424 (if (instance? (:on-interface protocol) x)425 x426 (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)))))))434 (defn find-protocol-method [protocol methodk x]435 (get (find-protocol-impl protocol x) methodk))437 (defn- protocol?438 [maybe-p]439 (boolean (:on-interface maybe-p)))441 (defn- implements? [protocol atype]442 (and atype (.isAssignableFrom ^Class (:on-interface protocol) atype)))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))))451 (defn extenders452 "Returns a collection of the types explicitly extending protocol"453 {:added "1.2"}454 [protocol]455 (keys (:impls protocol)))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)))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 interf467 (find-protocol-method (.protocol cache) (.methodk cache) x))]468 (when-not f469 (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))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 [~ginterf481 (fn482 ~@(map483 (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 ~gthis491 ~@(map492 (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#))))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)))))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 p518 (str "method " (.sym v) " of protocol " (.sym p))519 (str "function " (.sym v)))))))))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-meta541 {:name (vary-meta mname assoc :doc doc :arglists arglists)542 :arglists arglists543 :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 `(do551 (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) merge556 (assoc ~opts557 :sigs '~sigs558 :var (var ~name)559 :method-map560 ~(and (:on opts)561 (apply hash-map562 (mapcat563 (fn [s]564 [(keyword (:name s)) (keyword (or (:on s) (:name s)))])565 (vals sigs))))566 :method-builders567 ~(apply hash-map568 (mapcat569 (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)))576 (defmacro defprotocol577 "A protocol is a named set of named methods and their signatures:578 (defprotocol AProtocolName580 ;optional doc string581 \"A doc string for AProtocol abstraction\"583 ;method signatures584 (bar [this a b] \"bar docs\")585 (baz [this a] [this a b] [this a b c] \"baz docs\"))587 No implementations are provided. Docs can be specified for the588 protocol overall and for each method. The above yields a set of589 polymorphic functions and a protocol object. All are590 namespace-qualified by the ns enclosing the definition The resulting591 functions dispatch on the type of their first argument, which is592 required and corresponds to the implicit target object ('this' in593 Java parlance). defprotocol is dynamic, has no special compile-time594 effect, and defines no new types or classes. Implementations of595 the protocol methods can be provided using extend.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 will600 have methods corresponding to the protocol functions, and the601 protocol will automatically work with instances of the interface.603 Note that you should not use this interface with deftype or604 reify, as they support the protocol directly:606 (defprotocol P607 (foo [this])608 (bar-me [this] [this y]))610 (deftype Foo [a b c]611 P612 (foo [this] a)613 (bar-me [this] b)614 (bar-me [this y] (+ c y)))616 (bar-me (Foo. 1 2 3) 42)617 => 45619 (foo620 (let [x 42]621 (reify P622 (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))630 (defn extend631 "Implementations of protocol methods can be provided using the extend construct:633 (extend AType634 AProtocol635 {:foo an-existing-fn636 :bar (fn [a b] ...)637 :baz (fn ([a]...) ([a b] ...)...)}638 BProtocol639 {...}640 ...)642 extend takes a type/class (or interface, see below), and one or more643 protocol + method map pairs. It will extend the polymorphism of the644 protocol's methods to call the supplied methods when an AType is645 provided as the first argument.647 Method maps are maps of the keyword-ized method names to ordinary648 fns. This facilitates easy reuse of existing fns and fn maps, for649 code reuse/mixins without derivation or composition. You can extend650 an interface to a protocol. This is primarily to facilitate interop651 with the host (e.g. Java) but opens the door to incidental multiple652 inheritance of implementation since a class can inherit from more653 than one interface, both of which extend the protocol. It is TBD how654 to specify which impl to use. You can extend a protocol on nil.656 If you are supplying the definitions explicitly (i.e. not reusing657 exsting functions or mixin maps), you may find it more convenient to658 use the extend-type or extend-protocol macros.660 Note that multiple independent extend clauses can exist for the same661 type, not all protocols need be defined in a single extend call.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))))677 (defn- emit-impl [[p fs]]678 [p (zipmap (map #(-> % first keyword) fs)679 (map #(cons 'fn (drop 1 %)) fs))])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))]))693 (defn- emit-extend-type [c specs]694 (let [impls (parse-impls specs)]695 `(extend ~c696 ~@(mapcat (partial emit-hinted-impl c) impls))))698 (defmacro extend-type699 "A macro that expands into an extend call. Useful when you are700 supplying the definitions explicitly inline, extend-type701 automatically creates the maps required by extend. Propagates the702 class as a type hint on the first argument of all fns.704 (extend-type MyType705 Countable706 (cnt [c] ...)707 Foo708 (bar [x y] ...)709 (baz ([x] ...) ([x y & zs] ...)))711 expands into:713 (extend MyType714 Countable715 {:cnt (fn [c] ...)}716 Foo717 {:baz (fn ([x] ...) ([x y & zs] ...))718 :bar (fn [x y] ...)})"719 {:added "1.2"}720 [t & specs]721 (emit-extend-type t specs))723 (defn- emit-extend-protocol [p specs]724 (let [impls (parse-impls specs)]725 `(do726 ~@(map (fn [[t fs]]727 `(extend-type ~t ~p ~@fs))728 impls))))730 (defmacro extend-protocol731 "Useful when you want to provide several implementations of the same732 protocol all at once. Takes a single protocol and the implementation733 of that protocol for one or more types. Expands into calls to734 extend-type:736 (extend-protocol Protocol737 AType738 (foo [x] ...)739 (bar [x y] ...)740 BType741 (foo [x] ...)742 (bar [x y] ...)743 AClass744 (foo [x] ...)745 (bar [x y] ...)746 nil747 (foo [x] ...)748 (bar [x y] ...))750 expands into:752 (do753 (clojure.core/extend-type AType Protocol754 (foo [x] ...)755 (bar [x y] ...))756 (clojure.core/extend-type BType Protocol757 (foo [x] ...)758 (bar [x y] ...))759 (clojure.core/extend-type AClass Protocol760 (foo [x] ...)761 (bar [x y] ...))762 (clojure.core/extend-type nil Protocol763 (foo [x] ...)764 (bar [x y] ...)))"765 {:added "1.2"}767 [p & specs]768 (emit-extend-protocol p specs))