protocol_proxy.clj

(ns protocol-proxy
  "for when you have an object foo, which satisfies some protocols and you want to make adhoc changes to 
  one or more of the protocol methods, but just on foo. 
  
  Can be handy for testing. 
  "
  (:refer-clojure :exclude [proxy])
  (:require [clojure.string :as string]))
;(remove-ns 'protocol-proxy)

(defn satisfies
  "returns list of (extendable-via-metadata) protocols that x satisfies"
  [x]
  (->> (class x)
       (supers)
       (keep (fn [clazz]
               (let [class-sym (-> (.getCanonicalName clazz)
                                   (string/replace #"_" "-"))
                     i (string/last-index-of class-sym ".")
                     proto-sym (symbol (subs class-sym 0 i) (subs class-sym (inc i)))]
                 (try
                   (let [p (var-get (resolve proto-sym))]
                     (and (:extend-via-metadata p) p))
                   (catch Throwable _)))))))

(defn proxy
  "creates an object which satisfies all the metadata-extendable protocols of 'proxied', 
   so that calling the method on the new object will call through to 'proxied'
   except for methods in the arg 'overrides' map.
   
   Only works on protocols which have ':extend-via-metadata true'
   
   optional 3rd arg is the object which the protocol will be extended to (via metadata)
    
   "
  ([proxied overrides]
   (proxy proxied overrides {}))
  ([proxied overrides o]
   (let [protos (satisfies proxied)
         call-thrus
         (->> protos
              (mapcat
                (fn [{:keys [sigs] :as resolved-protocol}]
                  (->> sigs
                       (mapv
                         (fn [[_method-name {:keys [arglists] :as method}]]
                           (let [fn-sym (symbol
                                          (-> resolved-protocol :var symbol namespace name)
                                          (name (:name method)))
                                 fn-form `(fn ~@(->> arglists
                                                     (map (fn [arglist]
                                                            (list (vec (cons 'this (rest arglist)))
                                                              (concat (list fn-sym '(-> this meta :proxied))
                                                                (rest arglist)))))))]
                             [fn-sym
                              (try
                                (eval fn-form)
                                (catch Throwable t 
                                  (throw (ex-info "problem with call thru"
                                           {:form fn-form} t))))]))))))
              (into {}))]
     (-> o
         (with-meta
           (merge
             {:proxied proxied}
             call-thrus 
             overrides))))))

(defn no-op 
  "create a no-op impl of protocol"
  [protocol & protocols]
  (->> (cons protocol protocols)
       (mapcat (fn [protocol]
              (let [{:keys [sigs] :as resolved-protocol} protocol]
                (->> sigs
                     (mapv
                       (fn [[_method-name {:keys [arglists] :as method}]]
                         (let [fn-sym (symbol
                                        (-> resolved-protocol :var symbol namespace name)
                                        (name (:name method)))
                               fn-form `(fn ~@(->> arglists
                                                   (map (fn [arglist]
                                                          (list (vec (cons 'this (rest arglist)))
                                                            )))))]
                           [fn-sym
                            (try
                              (eval fn-form)
                              (catch Throwable t
                                (throw (ex-info "problem with call thru"
                                         {:form fn-form} t))))])))))))
       (into {})
       (with-meta {})))

(comment ;demo

  (defprotocol Foo
    :extend-via-metadata true
    (bar [_])
    (baz [_] [_ _]))

  (def a-foo (reify Foo
               (bar [_] "bar")
               (baz [_] "baz one")
               (baz [_ _] "baz two")))

  ; regular method call
  (bar a-foo) ;=> "bar"
  ; call overridden method
  (bar (proxy a-foo {`bar (fn [_] "my bar")})) ;=> "my bar"
  ; call a method not overridden
  (bar (proxy a-foo {})) ;=> "bar"

  ;multi-arity protocol methods
  (baz a-foo) ;=> "baz one"
  (baz a-foo :_) ;=> "baz two"
  (def a-foo-2 (proxy a-foo {`baz (fn ([_] "my baz one")
                                    ([_ _] "my baz two"))}))
  (baz a-foo-2) ; => "my baz one"
  (baz a-foo-2 :_) ; => "my baz two"

  ; wrapping 
  (bar (proxy a-foo {`bar (fn [_] (str (bar a-foo) " my bar"))})) ; => "bar my bar"

  ; source object 
  (def proxy-with-source (proxy a-foo
                           {`bar (fn [_] "my bar")}
                           {:source "xyz"}))
  proxy-with-source ;=> {:source "xyz"}
  ; call proxied fns as normal
  (bar proxy-with-source) ; => "my bar"
  )