(ns | |
#^{:doc "This is allows us to create Decoratable collection. | |
The idea is that the we a state map and add a key :decs which points to | |
a set of keys. Each of which is associated with a Decoration. We then | |
define a recursive mutifunction that grabs this :decs set and processes | |
each in turn (order is described later). | |
There are three types of decoration function. Centre is the main function, in | |
respect to which are defined pre and post functions that occur before and | |
after centre is called, respectively. | |
Each function is passed the collection and the & arguments, processes the | |
collection and hands it off to the next function in line. | |
Note that the decorations must be commutative with pre or post. | |
:default just pops the decorator and continues, to make a transparent | |
function, if its empty it just returns the collection to avoid inf recurs. | |
Check out the tests for examples of how to use this." | |
:author "Edmund Jackson" } | |
esjtools.decorate) | |
;------------------------------------------------------------------------------- | |
;; This uses a little bit of interface magic. All my timeseries functions take | |
;; the series as the first argument. So when chaining these things together | |
;; I'm making use of that fact. | |
;; Internal key | |
(def dk "decor-") | |
(defn name-dec | |
"Construct a name for our decorator multifn internals" | |
[x] | |
(symbol (str dk x))) | |
(defn decorate | |
"Add tags that define with Decorations on the collection" | |
[coll & tags] | |
(if (empty? tags) | |
coll | |
(apply update-in coll [:decs] conj tags))) | |
(defn undecorate | |
"Remove decorations" | |
[coll & tags] | |
(if (empty? tags) | |
coll | |
(apply update-in coll [:decs] disj tags))) | |
(defn dispatch-ts | |
"Dispatch function, pulls out the first decoration." | |
[decs & args] | |
(first decs)) | |
(defmacro def-decorated-pre-method | |
"This threads together Decorate function calls. These calls go before the | |
centre method." | |
[fn-name key disp-fn] | |
`(defmethod ~(name-dec fn-name) ~key [decs# dec-coll# & args#] | |
(~'apply ~(name-dec fn-name) (~'rest decs#) | |
(~'apply ~disp-fn dec-coll# args#) | |
args#))) | |
(defmacro def-decorated-centre-method | |
"This defines the main function in the decoration set, which is run for | |
all calls, and identified when the dispatcher returns nil. This stops | |
recursing." | |
[fn-name disp-fn] | |
`(defmethod ~(name-dec fn-name) nil | |
[decs# dec-coll# & args#] | |
(~'apply ~disp-fn dec-coll# args#))) | |
(defmacro def-decorated-post-method | |
"This threads together Decorate function calls, with the decorator coming | |
last." | |
[fn-name key disp-fn] | |
`(defmethod ~(name-dec fn-name) ~key [decs# dec-coll# & args#] | |
(~'apply ~disp-fn | |
(~'apply ~(name-dec fn-name) (~'rest decs#) | |
dec-coll# | |
args#) | |
args#))) | |
(defmacro def-decorated | |
"This generates interface functions that call the multimethod. The :default | |
method is to recurse, popping decorations until the list is empty, then | |
return the passed in collection." | |
[fn-name] | |
`(list (defmulti ~(name-dec fn-name) dispatch-ts) | |
(defn ~(symbol fn-name) [dec-coll# & args#] | |
(~'apply ~(name-dec fn-name) (:decs dec-coll#) dec-coll# args#)) | |
(defmethod ~(name-dec fn-name) :default | |
[decs# dec-coll# & args#] | |
(~'if (~'empty? decs#) | |
dec-coll# | |
(~'apply ~(name-dec fn-name) (~'rest decs#) dec-coll# args#))))) | |
;; -------------------------------------------------------------------------------------------------------- | |
(ns esjtools.decorate.test | |
(:use clojure.test | |
esjtools.decorate)) | |
;;; ---------------------------------------------------------------------------- | |
;;; Tests | |
;;; ---------------------------------------------------------------------------- | |
;;; Its kinda hard to test the output of macro is what I want it to be because | |
;;; its code, albeit, code-as-data. So instead I'm going to test by creating | |
;;; and calling macros and checking that they do what I want them to. | |
;;; Some helper functions. Admittedly not likely to be used in a Decorate, but | |
;;; easy to test its doing what we want | |
(defn out-data [coll & xs] | |
(conj (:data coll) :centre)) | |
(defn add-data [coll & xs] | |
(apply update-in coll [:data] conj xs)) | |
(defn out-data-b [coll & xs] | |
(conj (:data coll) :second)) | |
(defn pop-data [coll & xs] | |
(pop (:data coll))) | |
(defn rem-data [coll & xs] | |
(apply update-in coll [:data] disj xs)) | |
;;; ---------------------------------------------------------------------------- | |
(deftest test-decorate | |
(let [state {:data #{} | |
:decs #{}}] | |
;; Basic decoration | |
(are [x] (= x (:decs (apply decorate state x))) | |
#{} | |
#{:a} | |
#{:c :d}) | |
;; Basic undecoration | |
(are [x y] (= x (:decs | |
(apply undecorate | |
(decorate state :a :b :c :d) | |
y))) | |
#{:a :b :c :d} #{} | |
#{:a :b :c :d} #{:e :f} | |
#{:c :d} #{:a :b} | |
#{} #{:a :b :c :d}))) | |
;;; ---------------------------------------------------------------------------- | |
(deftest test-def-decorated-dispatch | |
(let [state {:data [:a] | |
:decs []}] | |
;; Basic pass through case. We want this just to spit out the input data. | |
(def-decorated test-fn) | |
(are [x y] (= x y) | |
state (test-fn state) | |
(decorate state :x) (test-fn (decorate state :x))) | |
;; Now bind a centre method, which should match the empty decoration list. | |
;; This is to return the :data element. Should bypass the unkown decs. | |
(def-decorated-centre-method test-fn out-data) | |
(are [x y] (= x y) | |
[:a :centre] (test-fn state) | |
[:a :centre] (test-fn (decorate state :x :y :z))) | |
;; Now add a pre method. We're using a vector because it preseves the | |
;; order of conj and disj so we can tell the order in which the decorations | |
;; have been applied | |
(def-decorated-pre-method test-fn :a add-data) | |
(are [x y] (= x y) | |
;; Make sure the undecorated stuff still works | |
[:a :centre] (test-fn state) | |
[:a :centre] (test-fn (decorate state :x :y :z)) | |
;; Now the new method. The order :a :b :centre assures of the order | |
;; of invocation. | |
[:a :b :centre] (test-fn (decorate state :a) :b) | |
[:a :b :centre] (test-fn (decorate state :x :a :z) :b)) | |
;; Add another pre function. Using a vec here for :deps, usually we | |
;; require that it be a set. | |
(def-decorated-pre-method test-fn :b add-data) | |
(are [x y] (= x y) | |
;; Make sure the previous stuff still works | |
[:a :centre] (test-fn state) | |
[:a :centre] (test-fn (decorate state :x :y :z)) | |
[:a :b :centre] (test-fn (decorate state :a) :b) | |
[:a :b :centre] (test-fn (decorate state :x :a :z) :b)) | |
;; Now the new method. | |
[:a :b :second :centre] (test-fn (decorate state :a :b) :b) | |
[:a :b :second :centre] (test-fn (decorate state :x :a :z :b) :b)) | |
;; Now add a post function | |
(def-decorated-post-method test-fn :qq pop-data) | |
(are [x y] (= x y) | |
;; Make sure the previous stuff still works | |
[:a :centre] (test-fn state) | |
[:a :centre] (test-fn (decorate state :x :y :z)) | |
[:a :b :centre] (test-fn (decorate state :a) :b) | |
[:a :b :centre] (test-fn (decorate state :x :a :z) :b)) | |
[:a :b :second :centre] (test-fn (decorate state :a :b) :b) | |
[:a :b :second :centre] (test-fn (decorate state :x :a :z :b) :b) | |
;; New Tests. This gets tortured as we are appling the same | |
;; arguments, too bad. | |
[:a :b :second] (test-fn (decorate state :a :b :qq) :b) | |
[:a :second :b] (test-fn (decorate state :x :b :z :a :qq) :b) | |
[:a :second :b] (test-fn (decorate state :qq :x :b :z :a) :b)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment