:delegate option for deftype

deftype+.clj

(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}}))