From 1ae03557ac783d7fbc00540abe415bbed799c17b Mon Sep 17 00:00:00 2001 From: Reid 'arrdem' McKenzie Date: Thu, 13 Oct 2016 12:37:59 -0700 Subject: [PATCH] Start working on refactoring defprotcol for syntax consistency with defn --- src/clj/clojure/core_deftype.clj | 200 ++++++++++++++++++------------- 1 file changed, 116 insertions(+), 84 deletions(-) diff --git a/src/clj/clojure/core_deftype.clj b/src/clj/clojure/core_deftype.clj index 42254aaf..45acf7b9 100644 --- a/src/clj/clojure/core_deftype.clj +++ b/src/clj/clojure/core_deftype.clj @@ -615,94 +615,126 @@ (str "method " (.sym v) " of protocol " (.sym p)) (str "function " (.sym v))))))))) +(defn- parse-sig [m s] + (let [name-meta (meta (first s)) + [name & s] s + [docstring? s] (take-if string? s) + [meta? s] (take-if map? s)] + + (when-not (symbol? name) + (throw + (IllegalArgumentException. + "Error parsing protocol signature, sig name must be a symbol"))) + + (when-not (vector? args) + (throw + (IllegalArgumentException. + "Error parsing protocol signature, args must be a vector"))) + + (validate-arglist args) + + (loop [as [] + rs (rest s)] + (if (vector? (first rs)) + (recur (conj as (first rs)) (next rs)) + [(seq as) (first rs)])) + + (when (some #{0} (map count arglists)) + (throw + (IllegalArgumentException. + (format "Definition of function %s in protocol %s must take at least one arg." + mname name)))) + (when (m (keyword mname)) + (throw + (IllegalArgumentException. + (format "Function %s in protocol %s was redefined. Specify all arities in single definition." + mname name)))) + (assoc m (keyword mname) + (merge name-meta + {:name (vary-meta mname + assoc + :doc doc + :arglists arglists) + :arglists arglists + :doc doc})))) + (defn- emit-protocol [name opts+sigs] - (let [iname (symbol (str (munge (namespace-munge *ns*)) "." (munge name))) - [opts sigs] - (loop [opts {:on (list 'quote iname) :on-interface iname} sigs opts+sigs] - (condp #(%1 %2) (first sigs) - string? (recur (assoc opts :doc (first sigs)) (next sigs)) - keyword? (recur (assoc opts (first sigs) (second sigs)) (nnext sigs)) - [opts sigs])) - sigs (when sigs - (reduce1 (fn [m s] - (let [name-meta (meta (first s)) - mname (with-meta (first s) nil) - [arglists doc] - (loop [as [] rs (rest s)] - (if (vector? (first rs)) - (recur (conj as (first rs)) (next rs)) - [(seq as) (first rs)]))] - (when (some #{0} (map count arglists)) - (throw (IllegalArgumentException. (str "Definition of function " mname " in protocol " name " must take at least one arg.")))) - (when (m (keyword mname)) - (throw (IllegalArgumentException. (str "Function " mname " in protocol " name " was redefined. Specify all arities in single definition.")))) - (assoc m (keyword mname) - (merge name-meta - {:name (vary-meta mname assoc :doc doc :arglists arglists) - :arglists arglists - :doc doc})))) - {} sigs)) - meths (mapcat (fn [sig] - (let [m (munge (:name sig))] - (map #(vector m (vec (repeat (dec (count %)) 'Object)) 'Object) - (:arglists sig)))) - (vals sigs))] - `(do - (defonce ~name {}) - (gen-interface :name ~iname :methods ~meths) - (alter-meta! (var ~name) assoc :doc ~(:doc opts)) - ~(when sigs - `(#'assert-same-protocol (var ~name) '~(map :name (vals sigs)))) - (alter-var-root (var ~name) merge - (assoc ~opts - :sigs '~sigs - :var (var ~name) - :method-map - ~(and (:on opts) - (apply hash-map - (mapcat - (fn [s] - [(keyword (:name s)) (keyword (or (:on s) (:name s)))]) - (vals sigs)))) - :method-builders - ~(apply hash-map - (mapcat - (fn [s] - [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)}))) - (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))]) - (vals sigs))))) - (-reset-methods ~name) - '~name))) + (let [iname (symbol (str (munge (namespace-munge *ns*)) "." (munge name))) + [docstring? opts+sigs] (take-if string? opts+sigs) + [meta? sigs] (take-if map? opts+sigs) + opts (-> (meta name) + (merge {:on (list 'quote iname) + :on-interface iname}) + (cond-> + meta? (merge meta?) + docstring? (assoc :doc docstring?))) + sigs (when sigs + (reduce1 parse-sig {} sigs)) + meths (mapcat (fn [sig] + (let [m (munge (:name sig))] + (map #(vector m (vec (repeat (dec (count %)) 'Object)) 'Object) + (:arglists sig)))) + (vals sigs))] + `(do (defonce ~name {}) + (gen-interface :name ~iname :methods ~meths) + (alter-meta! (var ~name) assoc :doc ~(:doc opts)) + ~(when sigs + `(#'assert-same-protocol (var ~name) '~(map :name (vals sigs)))) + (alter-var-root (var ~name) merge + (assoc ~opts + :sigs '~sigs + :var (var ~name) + :method-map + ~(and (:on opts) + (apply hash-map + (mapcat + (fn [s] + [(keyword (:name s)) (keyword (or (:on s) (:name s)))]) + (vals sigs)))) + :method-builders + ~(apply hash-map + (mapcat + (fn [s] + [`(intern *ns* (with-meta '~(:name s) (merge '~s {:protocol (var ~name)}))) + (emit-method-builder (:on-interface opts) (:name s) (:on s) (:arglists s))]) + (vals sigs))))) + (-reset-methods ~name) + '~name))) (defmacro defprotocol "A protocol is a named set of named methods and their signatures: (defprotocol AProtocolName - - ;optional doc string + ; optional doc string \"A doc string for AProtocol abstraction\" - - ;method signatures - (bar [this a b] \"bar docs\") - (baz [this a] [this a b] [this a b c] \"baz docs\")) - - No implementations are provided. Docs can be specified for the - protocol overall and for each method. The above yields a set of - polymorphic functions and a protocol object. All are - namespace-qualified by the ns enclosing the definition The resulting - functions dispatch on the type of their first argument, which is - required and corresponds to the implicit target object ('this' in - Java parlance). defprotocol is dynamic, has no special compile-time - effect, and defines no new types or classes. Implementations of - the protocol methods can be provided using extend. - - defprotocol will automatically generate a corresponding interface, - with the same name as the protocol, i.e. given a protocol: - my.ns/Protocol, an interface: my.ns.Protocol. The interface will - have methods corresponding to the protocol functions, and the - protocol will automatically work with instances of the interface. - - Note that you should not use this interface with deftype or - reify, as they support the protocol directly: + ; optional metadata + {:author [\"Ada Lovelace \"]} + ; method signatures + (bar + \"bar docs\" + {:foo :bar} + [this a b]) + (baz + \"baz docs\" + {:baz :qux} + [this a] + [this a b] + [this a b c])) + + No implementations are provided. Docs can be specified for the protocol overall and for each + method. The above yields a set of polymorphic functions and a protocol object. All are + namespace-qualified by the ns enclosing the definition The resulting functions dispatch on the + type of their first argument, which is required and corresponds to the implicit target + object ('this' in Java parlance). defprotocol is dynamic, has no special compile-time effect, and + defines no new types or classes. Implementations of the protocol methods can be provided using + extend. + + defprotocol will automatically generate a corresponding interface, with the same name as the + protocol, i.e. given a protocol: my.ns/Protocol, an interface: my.ns.Protocol. The interface will + have methods corresponding to the protocol functions, and the protocol will automatically work + with instances of the interface. + + Note that you should not use this interface with deftype or reify, as they support the protocol + directly: (defprotocol P (foo [this]) @@ -724,7 +756,8 @@ (bar-me [this] x) (bar-me [this y] x)))) => 17" - {:added "0.1.0"} + {:added "0.1.0" + :arglists '([name docstring? attr-map? & sigs])} [name & opts+sigs] (emit-protocol name opts+sigs)) @@ -867,4 +900,3 @@ [p & specs] (emit-extend-protocol p specs)) -