Skip to content
This repository has been archived by the owner on Jan 28, 2019. It is now read-only.

Commit

Permalink
Start working on refactoring defprotcol for syntax consistency with defn
Browse files Browse the repository at this point in the history
  • Loading branch information
@arrdem
arrdem committed Oct 13, 2016
1 parent 7bd9802 commit 1ae0355
Showing 1 changed file with 116 additions and 84 deletions.
200 changes: 116 additions & 84 deletions src/clj/clojure/core_deftype.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 <[email protected]>\"]}
; 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])
Expand All @@ -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))

Expand Down Expand Up @@ -867,4 +900,3 @@

[p & specs]
(emit-extend-protocol p specs))

0 comments on commit 1ae0355

Please sign in to comment.