1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/sunil/curry.clj	Tue Oct 18 00:48:50 2011 -0700
     1.3 @@ -0,0 +1,134 @@
     1.4 +(ns sunil.curry)
     1.5 +
     1.6 +(defmacro def-curry-fn [name args & body]
     1.7 +  {:pre [(not-any? #{'&} args)]}
     1.8 +  (if (empty? args)
     1.9 +    `(defn ~name ~args ~@body)
    1.10 +    (let [rec-funcs (reduce (fn [l v]
    1.11 +			      `(letfn [(helper#
    1.12 +					([] helper#)
    1.13 +					([x#] (let [~v x#] ~l))
    1.14 +					([x# & rest#] (let [~v x#]
    1.15 +							(apply (helper# x#) rest#))))]
    1.16 +				 helper#))
    1.17 +			    `(do ~@body) (reverse args))]
    1.18 +      `(defn ~name [& args#]
    1.19 +	 (let [helper# ~rec-funcs]
    1.20 +	   (apply helper# args#))))))
    1.21 +
    1.22 +
    1.23 +(defn partial+
    1.24 +  "Takes a function f and fewer than the normal arguments to f, and
    1.25 +  returns a fn that takes a variable number of additional args. When
    1.26 +  called, the returned function calls f with args + additional args.
    1.27 +  differs from the core version in that it works on just one argument."
    1.28 +  {:added "1.0"}
    1.29 +  ([f] f)
    1.30 +  ([f arg1]
    1.31 +   (fn [& args] (apply f arg1 args)))
    1.32 +  ([f arg1 arg2]
    1.33 +   (fn [& args] (apply f arg1 arg2 args)))
    1.34 +  ([f arg1 arg2 arg3]
    1.35 +   (fn [& args] (apply f arg1 arg2 arg3 args)))
    1.36 +  ([f arg1 arg2 arg3 & more]
    1.37 +   (fn [& args] (apply f arg1 arg2 arg3 (concat more args)))))
    1.38 +
    1.39 +
    1.40 +(defmacro decorate
    1.41 +  "given an unqualified symbol, redefines the associated var to exist in the current
    1.42 +   namespace and be decorated with the array of decorators.
    1.43 +   Example:
    1.44 +   (decorate + memoize)"
    1.45 +  [sym & decorations]
    1.46 +  (let 	[decorations (vec decorations)
    1.47 +	 str-decorations (apply str (interleave decorations " "))]
    1.48 +  `(let [target-var# (resolve (quote ~sym))
    1.49 +	 old-meta# (meta target-var#)
    1.50 +	 value-of-sym# (var-get target-var#)
    1.51 +
    1.52 +	 new-meta# (update-in old-meta# [:doc]
    1.53 +			     #(str "*Decorated with: [ "
    1.54 +				   ~str-decorations "]*"  \newline
    1.55 +				   %))]
    1.56 +     (rlm.rlm-commands/undef ~sym)
    1.57 +     (intern
    1.58 +      *ns*
    1.59 +      (with-meta (quote ~sym) new-meta#)
    1.60 +      ((reduce comp identity (reverse ~decorations)) value-of-sym#)))))
    1.61 +    
    1.62 +
    1.63 +(defmacro defn-decorated
    1.64 +  "like defn except it accepts an additional vector of
    1.65 +   decorator functions which will be applied to the base definition.
    1.66 +   the decorators are applied in left-to-right order."
    1.67 +  {:author "Robert McIntyre"
    1.68 +   :arglists '[[name [modifers*] doc-string? attr-map? [params*] body]
    1.69 +	       [name [modifers*] doc-string? attr-map? ([params*] body) + attr-map?]]}
    1.70 +  [fn-name decorators & defn-stuff]
    1.71 +  `(do
    1.72 +     (defn ~fn-name ~@defn-stuff)
    1.73 +     (alter-var-root (var ~fn-name) (reduce comp identity (reverse ~decorators)))
    1.74 +     (var ~fn-name)))
    1.75 +
    1.76 +
    1.77 +(defn curry+
    1.78 +  "another way to do it, curry+, thanks to duncant"
    1.79 +  ([num-args f eval-list]
    1.80 +     (if (= num-args (count eval-list))
    1.81 +       (apply f eval-list)
    1.82 +       (fn [& args]
    1.83 +	 (curry+ num-args f (concat eval-list args)))))
    1.84 +  ([num-args f]
    1.85 +     (curry+ num-args f '())))
    1.86 +
    1.87 +(defn curry**
    1.88 +  "curry classic. rlm. consumes stack like a mother"
    1.89 +  [num-args f]
    1.90 +  (fn [& args]
    1.91 +    (let [num-inputs (count args)]
    1.92 +      (if (= num-inputs num-args)
    1.93 +	(apply f args)
    1.94 +	(curry** (- num-args num-inputs)
    1.95 +		 (fn [& more] (apply f (concat args more))))))))
    1.96 +
    1.97 +(defn curry++
    1.98 +  "takes a function with a fixed number of args and modifies
    1.99 +   it to that it will be automaticaly curried when called with
   1.100 +   less args"
   1.101 +  ([num-args f & eval-list]
   1.102 +     (if (= num-args (count eval-list))
   1.103 +       (apply f eval-list)
   1.104 +       (fn [& args]
   1.105 +	 (apply curry++ num-args f (concat eval-list args))))))
   1.106 +
   1.107 +  
   1.108 +
   1.109 +
   1.110 +(def curry* (curry++ 2 curry++))
   1.111 +
   1.112 +(defn-decorated
   1.113 +  curry
   1.114 +  [(curry* 2)]
   1.115 +  "higher order function that enables automatic curying as in haskel, scheme"
   1.116 +  {:author "Robert McIntyre"}
   1.117 +  [number-of-args f]
   1.118 +  (curry++ number-of-args f))
   1.119 +
   1.120 +
   1.121 +
   1.122 +;;; Example of Use
   1.123 +
   1.124 +(defn-decorated
   1.125 +  demo
   1.126 +  [memoize (curry 3)]
   1.127 +  "I like the vector of unitarty higher order transforms ---
   1.128 +   sort of like a list of modifiers on a magic(tm) card.
   1.129 +   This function has flying, resistance to black, etc :)"
   1.130 +  [a b c]
   1.131 +  (println "side effect")
   1.132 +  (+ a b c))
   1.133 +
   1.134 +
   1.135 +;; (((((demo1)) 1) 2) 3)
   1.136 +;; 6
   1.137 +