Skip to content

Commit

Permalink
Make wrapping-related stuff more function and less macro. Allow alrea…
Browse files Browse the repository at this point in the history 
…dy-defined vars to be altered for use with wrappers
  • Loading branch information
@amalloy
amalloy committed Aug 5, 2011
1 parent cc83eb5 commit c122e3e
Show file tree
Hide file tree
Showing 2 changed files with 95 additions and 65 deletions.
45 changes: 27 additions & 18 deletions src/useful/experimental.clj
View file
Expand Up @@ -130,6 +130,30 @@
(extend ~name
~@(apply concat proto-fns))))))

(defn wrap-with [f wrapper-var & [name]]
(with-meta
(fn [& args]
(let [wrappers (not-empty @wrapper-var)]
(if-not wrappers
(apply f args)
(with-bindings {wrapper-var
(vary-meta wrappers assoc
::call-data {:fn-name name})}
(apply (reduce (fn [f wrapper]
(wrapper f))
f
wrappers)
args)))))
(meta f)))

(defn make-wrappable! [fn-var wrappers-var & [name]]
(alter-var-root fn-var wrap-with wrappers-var name))

(defmacro wrap-multiple [wrappers-var & fn-syms]
(cons `do
(for [f fn-syms]
`(make-wrappable! #'~f ~wrappers-var '~f))))

(defmacro defn-wrapping
"Define a function as with defn, which checks the contents of wrappers-var
whenever it is called. If that var is empty, the underlying defn is called
Expand All @@ -155,24 +179,9 @@
Note the order of the wrapping: when called with 10 as an argument, the former
will return -40, and the latter 0."
[name wrappers-var & defn-args]
(let [[name macro-args] (name-with-attributes name defn-args)
fake-defn-name (gensym 'tmp)]
`(let [impl# (fn ~@macro-args)
fake-defn-var# (defn ~fake-defn-name ~@macro-args)
arglists# (-> fake-defn-var# meta :arglists)]
(ns-unmap *ns* '~fake-defn-name)
(defn ~name {:arglists arglists#} [& args#]
(let [wrappers# (not-empty @~wrappers-var)]
(if-not wrappers#
(apply impl# args#)
(with-bindings {~wrappers-var
(vary-meta wrappers# assoc
::call-data {:fn-name '~name})}
(apply (reduce (fn [f# wrapper#]
(wrapper# f#))
impl#
wrappers#)
args#))))))))
(let [[name macro-args] (name-with-attributes name defn-args)]
`(doto (defn ~name ~@macro-args)
(make-wrappable! ~wrappers-var '~name))))

(defmacro with-wrappers
"Dynamically bind some additional wrappers to the specified wrapper-var
Expand Down
115 changes: 68 additions & 47 deletions test/useful/experimental_test.clj
View file
Expand Up @@ -65,51 +65,72 @@
(is (= {:f 'lookup :args [1] :ret :not-found} @call-log)))))

(deftest wrapper-test
(testing "Wrapping respects manually-established bindings"
(with-local-vars [wrappers ()]
(defn-wrapping my-inc wrappers "add one" [x]
(+ 1 x))
(is (= 2 (my-inc 1)))
(let [start-num 1]
(is (= (* 2 (inc (+ 10 start-num)))
(with-bindings {wrappers (list (fn [f] ;; outermost wrapper
(fn [x]
(* 2 (f x))))
(fn [f] ;; innermost wrapper
(fn [x]
(f (+ 10 x)))))}
(my-inc start-num)))))
(let [call-log (atom nil)]
(is (= 2 (with-bindings {wrappers (list (fn [f]
(with-local-vars [dummy-wrapper ()]
(testing "Wrapping respects manually-established bindings"
(with-local-vars [wrappers ()]
(defn-wrapping my-inc wrappers "add one" [x]
(+ 1 x))
(is (= 2 (my-inc 1)))
(let [start-num 1]
(is (= (* 2 (inc (+ 10 start-num)))
(with-bindings {wrappers (list (fn [f] ;; outermost wrapper
(fn [x]
(let [ret (f x)]
(reset! call-log [(-> wrappers deref meta :useful.experimental/call-data :fn-name) x ret])
ret))))}
(my-inc 1))))
(testing "Wrapping-related metadata bound correctly"
(is (= ['my-inc 1 2] @call-log))))))

(testing "with-wrapper(s) works"
(let [prepend (fn [item] (fn [f] (fn [& args] (apply f item args))))
append (fn [item] (fn [f] (fn [& args] (apply f (concat args [item])))))]
(with-local-vars [vec-wrapper []
cons-wrapper ()]
(defn-wrapping vec-str vec-wrapper "Make stuff a string" [& args]
(apply str args))
(defn-wrapping cons-str cons-wrapper "Make stuff a string" [& args]
(apply str args))
(with-wrapper vec-wrapper (prepend 'foo)
(is (= "foo123" (vec-str 1 2 3)))
(with-wrapper vec-wrapper (append 'bar)
(is (= "foo123bar" (vec-str 1 2 3)))
(with-wrapper vec-wrapper (prepend 'baz)
(is (= "foobaz123bar" (vec-str 1 2 3))))))
(with-wrappers cons-wrapper [(prepend 'foo) (append 'bar) (prepend 'baz)]
(is (= "bazfoo123bar" (cons-str 1 2 3)))))))

(testing "Metadata is applied properly"
(defn-wrapping myfn nil "re-implement clojure.core/first." [[x]]
x)
(let [meta (meta #'myfn)]
(is (= '([[x]]) (:arglists meta)))
(is (= "re-implement clojure.core/first." (:doc meta))))))
(* 2 (f x))))
(fn [f] ;; innermost wrapper
(fn [x]
(f (+ 10 x)))))}
(my-inc start-num)))))
(let [call-log (atom nil)]
(is (= 2 (with-bindings {wrappers (list (fn [f]
(fn [x]
(let [ret (f x)]
(reset! call-log [(-> wrappers deref meta :useful.experimental/call-data :fn-name) x ret])
ret))))}
(my-inc 1))))
(testing "Wrapping-related metadata bound correctly"
(is (= ['my-inc 1 2] @call-log))))))

(testing "with-wrapper(s) works"
(let [prepend (fn [item] (fn [f] (fn [& args] (apply f item args))))
append (fn [item] (fn [f] (fn [& args] (apply f (concat args [item])))))]
(with-local-vars [vec-wrapper []
cons-wrapper ()]
(defn-wrapping vec-str vec-wrapper "Make stuff a string" [& args]
(apply str args))
(defn-wrapping cons-str cons-wrapper "Make stuff a string" [& args]
(apply str args))
(with-wrapper vec-wrapper (prepend 'foo)
(is (= "foo123" (vec-str 1 2 3)))
(with-wrapper vec-wrapper (append 'bar)
(is (= "foo123bar" (vec-str 1 2 3)))
(with-wrapper vec-wrapper (prepend 'baz)
(is (= "foobaz123bar" (vec-str 1 2 3))))))
(with-wrappers cons-wrapper [(prepend 'foo) (append 'bar) (prepend 'baz)]
(is (= "bazfoo123bar" (cons-str 1 2 3)))))))

(testing "Metadata is applied properly"
(defn-wrapping myfn dummy-wrapper "re-implement clojure.core/first." [[x]]
x)
(let [meta (meta #'myfn)]
(is (= '([[x]]) (:arglists meta)))
(is (= "re-implement clojure.core/first." (:doc meta))))

(testing "Docstring is optional"
(defn-wrapping testfn dummy-wrapper [x]
(inc x))
(is (= 1 (testfn 0)))))

(let [inc-fn (fn [f] (comp inc f))]
(testing "Wrapper can be added after function is defined"
(defn frizzle [x] (inc x))
(make-wrappable! #'frizzle dummy-wrapper)
(is (= 3 (with-wrapper dummy-wrapper inc-fn
(frizzle 1)))))

(testing "wrap-multiple"
(defn frazzle [x] (inc x))
(defn zazzle [x] (inc x))
(wrap-multiple dummy-wrapper frazzle zazzle)
(are [f] (= 3 (with-wrapper dummy-wrapper inc-fn
(f 1)))
frazzle zazzle)))))

0 comments on commit c122e3e

Please sign in to comment.