Skip to content

Instantly share code, notes, and snippets.

@jclaggett
Created March 10, 2014 13:32
Show Gist options
  • Save jclaggett/9464982 to your computer and use it in GitHub Desktop.
Save jclaggett/9464982 to your computer and use it in GitHub Desktop.
:delegate option for deftype
(ns deftype+
"Augmented deftype sporting a new :delegate option.")
;; code to get the methods of interfaces and protocols
(defmulti get-methods
"Return a map of all method names to their arity."
class)
(defmethod get-methods clojure.lang.PersistentArrayMap
[protocol]
(->> (:sigs protocol)
vals
(map (juxt :name
#(-> % :arglists first count)))
(into {})))
(defmethod get-methods java.lang.Class
[interface]
(->> interface
(.getDeclaredMethods)
(map (juxt #(-> % .getName symbol)
#(-> % .getParameterTypes count)))
(into {})))
;; use the hidden parsing functions in clojure.core
(def parse-opts (resolve 'clojure.core/parse-opts))
(def parse-impls (resolve 'clojure.core/parse-impls))
;; supporting functions for deftype+ macro
(defn emit-delegation-method
"Emit a delegation method. If the method is an updater, be sure to wrap the
results in a new instance of the overall type."
[delegate fname arity updater? tname fields]
(let [fname-meth (symbol (str "." fname))
tname-ctor (symbol (str tname "."))
fargs (repeatedly arity (partial gensym "arg-"))
self (gensym "this-")
fbody `(~fname-meth ~delegate ~@fargs)
fbody (if updater?
`(~tname-ctor ~@(replace {delegate fbody} fields))
fbody)]
`(~fname [~self ~@fargs] ~fbody)))
(defn mapify-methods
"Convert the vector of methods into a map with the name of each method as the
key."
[impls]
(reduce-kv
(fn [impls iname methods]
(assoc impls
iname
(reduce (fn [m [name :as method]]
(assoc m name method))
{}
methods)))
impls
impls))
(defn add-delegations
"Work through the delegation-specs adding all needed delegation methods to
impls."
[impls delegation-specs tname fields]
(reduce-kv
(fn [impls delegate impl-specs]
(reduce-kv
(fn [impls iname directives]
(assoc impls iname
(reduce-kv
(fn [methods name arity]
(if (or (contains? methods name)
(= :ignore (directives name)))
methods
(assoc methods name
(emit-delegation-method
delegate
name arity
(= :update (directives name))
tname
fields))))
(get impls iname {})
(get-methods (resolve iname)))))
impls
(eval impl-specs)))
impls
delegation-specs))
(defn flatten-maps
"Flatten the impl map (and nested method map) into a vector."
[impls]
(reduce-kv
(fn [specs iname methods]
(concat specs
[iname]
(vals methods)))
[]
impls))
(defmacro deftype+
"Built on top of clojure's standard deftype and is the same in every way
except that a new :delegate option is supported.
The :delegate option takes as a value a map of field names to delegate-specs.
delegate-specs are used to describe the interfaces and protocols that the
deftype wishes to delegate to the value in the specified field. This makes it
easy for a new type to behave as an existing clojure data type and still have
the ability to modify that behavior in specific ways.
Example:
(deftype+ MyMap [sub-map]
:delegate {sub-map ClojureMap} ;; act like a map
clojure.lang.IPersistentMap
;; manually define just the assoc behavior
(assoc [_ k v]
(println \"Associng a new key into map: \" k)
(MyMap. (.assoc sub-map k v))))
;; MyMap acts just like a map.
(-> (MyMap. {:a 1})
(assoc :b 2))"
[tname fields & opts+specs]
(let [[opts specs] (parse-opts opts+specs)
specs (-> specs
parse-impls
mapify-methods
(add-delegations (:delegate opts) tname fields)
flatten-maps)
opts (-> opts
(dissoc :delegate)
(->> (mapcat identity)))]
`(deftype ~tname ~fields ~@opts ~@specs)))
;; This is a library of delegate-specs. Each key in the spec is an interface or
;; protocol and each value is a submap with method specific directives. This
;; submap has method names as keys and one of three keywords as values: :get
;; (default) :update :skip. If no method is specified the submap :get is
;; assumed. :get means that the results of the delegated method are directly
;; returned. :update means that the results are wrapped in a new instance of the
;; overall type. :ignore will supply no delegate for this method.
(def ClojureMeta
'{clojure.lang.IObj
{withMeta :update}
clojure.lang.IMeta
{meta :get}})
(def ClojureCommon
(merge ClojureMeta
'{clojure.lang.IPersistentCollection
{count :get
cons :update
empty :update}
clojure.lang.Seqable
{seq :get}
clojure.lang.ILookup
{valAt :get}
;; invoke has some kind of weird arity issue
;;clojure.lang.IFn
;; {invoke :get}
java.lang.Iterable
{iterator :get}}))
(def ClojureMap
(merge ClojureCommon
'{clojure.lang.IPersistentMap
{assoc :update
assocEx :update
without :update}
clojure.lang.Associative
{assoc :ignore
containsKey :get
entryAt :get} }))
(def ClojureSet
(merge ClojureCommon
'{clojure.lang.IPersistentSet
{disjoin :update
contains :get
get :get}}))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment