gistfile1.clj

(defn- parse-protocol-specs
  "Takes a list of symbols and function implementations as expected by
   the deftype function, and returns the symbols and maps expected by
   the extend macro."
  [lst]
  (loop [ret {}
	 specs lst]
    (if (empty? specs)
      ret
      (recur (conj ret [(first specs) (take-while seq? (next specs))])
	     (drop-while seq? (next specs))))))

(defn- create-impl-map
  "Takes a vector containing two items: the symbol naming a protocol, and
   a sequence of the implementation functions as you might write them in
   deftype. Transforms this in a vector pair containing the symbol naming
   the protocol and the implementations as a map you might pass to extend."
  [[protocol impl-seq]]
  [protocol (zipmap (map #(-> % first keyword) impl-seq)
		    (map #(list 'fn (rest %)) impl-seq))])

(defmacro defimplementation
  "This macro takes a name followed by the arguments you might give to deftype
   when you are implementing its protocols (ie, a symbol followed by function
   implementations, repeated as needed). It creates a map with the given name
   that maps protocols to the function map the extend macro would expect."
  [name & args]
  (let [fn-specs (parse-protocol-specs args)
	specs-map (apply hash-map (mapcat create-impl-map fn-specs))]
    `(def ~name ~specs-map)))

(defn- parse-mixin-directives
  [[implementation & args]]
  (loop [ret {}
	 [directive & remaining-args] args]
    (condp = directive
      :override (let [overrides (parse-protocol-specs
				 (take-while #(not (keyword? %))
					     remaining-args))]
		  (recur (hash-map (map #(vector (first %)
						 (merge (second %)
							(overrides (first %))))
					implementation))
			 (drop-while #(not (keyword? %)) remaining-args)))
      :only (let [included-protocols (take-while symbol remaining-args)]
	      (recur (reduce #(merge %1 (implementation %2))
			     ret included-protocols)
		     (drop-while symbol remaining-args)))
      :else (throw (IllegalArgumentException.
		    "Expected one of: :override, :only.")))))

(defn- parse-mixin-impls
  [args]
  (loop [ret {}
	 impls args]
    (if (empty? impls)
      ret
      (cond (symbol? (first impls))
	    (conj ret [(first impls) (eval (first impls))])
	    (vector? (first impls))
	    (let [impl-map (parse-mixin-directives (first impls))]
	      (conj ret impl-map))
	    :else (throw (IllegalArgumentException.
			  "Expected a symbol or vector of implementations."))))))

(defmacro mixin
  [name & args]
  (let [final-impls (parse-mixin-impls args)]
    (prn final-impls)
    (prn (concat (map #(second %) final-impls))) ; Need to get the items out of the list of impls->{prot fns} maps.
    `(extend ~name ~@(concat (map #(second %) final-impls)))))

;; To make it cause the exception: 

(defprotocol UpstreamHandler
  "Protocol to mirror the functionality in SimpleChannelUpstreamHandler."
  (channelBound           [this ctx e])
  (channelClosed          [this ctx e])
  (channelConnected       [this ctx e])
  (channelDisconnected    [this ctx e])
  (channelInterestChanged [this ctx e])
  (channelOpen            [this ctx e])
  (channelUnbound         [this ctx e])
  (childChannelClosed     [this ctx e])
  (childChannelOpen       [this ctx e])
  (exceptionCaught        [this ctx e])
  (messageReceived        [this ctx e])
  (writeComplete          [this ctx e]))

(defimplementation TestImpl UpstreamHandler (channelBound [this ctx e] (println  "Hi.")))

(deftype TestType [])

(mixin TestType TestImpl)