gistfile1.lisp

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