Mercurial > curry

comparison src/sunil/curry.clj @ 0:7cef0e03f29e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
initial commit
author Robert McIntyre <rlm@mit.edu>
date Tue, 18 Oct 2011 00:48:50 -0700
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:7cef0e03f29e
1 (ns sunil.curry)
2
3 (defmacro def-curry-fn [name args & body]
4 {:pre [(not-any? #{'&} args)]}
5 (if (empty? args)
6 `(defn ~name ~args ~@body)
7 (let [rec-funcs (reduce (fn [l v]
8 `(letfn [(helper#
9 ([] helper#)
10 ([x#] (let [~v x#] ~l))
11 ([x# & rest#] (let [~v x#]
12 (apply (helper# x#) rest#))))]
13 helper#))
14 `(do ~@body) (reverse args))]
15 `(defn ~name [& args#]
16 (let [helper# ~rec-funcs]
17 (apply helper# args#))))))
18
19
20 (defn partial+
21 "Takes a function f and fewer than the normal arguments to f, and
22 returns a fn that takes a variable number of additional args. When
23 called, the returned function calls f with args + additional args.
24 differs from the core version in that it works on just one argument."
25 {:added "1.0"}
26 ([f] f)
27 ([f arg1]
28 (fn [& args] (apply f arg1 args)))
29 ([f arg1 arg2]
30 (fn [& args] (apply f arg1 arg2 args)))
31 ([f arg1 arg2 arg3]
32 (fn [& args] (apply f arg1 arg2 arg3 args)))
33 ([f arg1 arg2 arg3 & more]
34 (fn [& args] (apply f arg1 arg2 arg3 (concat more args)))))
35
36
37 (defmacro decorate
38 "given an unqualified symbol, redefines the associated var to exist in the current
39 namespace and be decorated with the array of decorators.
40 Example:
41 (decorate + memoize)"
42 [sym & decorations]
43 (let [decorations (vec decorations)
44 str-decorations (apply str (interleave decorations " "))]
45 `(let [target-var# (resolve (quote ~sym))
46 old-meta# (meta target-var#)
47 value-of-sym# (var-get target-var#)
48
49 new-meta# (update-in old-meta# [:doc]
50 #(str "*Decorated with: [ "
51 ~str-decorations "]*" \newline
52 %))]
53 (rlm.rlm-commands/undef ~sym)
54 (intern
55 *ns*
56 (with-meta (quote ~sym) new-meta#)
57 ((reduce comp identity (reverse ~decorations)) value-of-sym#)))))
58
59
60 (defmacro defn-decorated
61 "like defn except it accepts an additional vector of
62 decorator functions which will be applied to the base definition.
63 the decorators are applied in left-to-right order."
64 {:author "Robert McIntyre"
65 :arglists '[[name [modifers*] doc-string? attr-map? [params*] body]
66 [name [modifers*] doc-string? attr-map? ([params*] body) + attr-map?]]}
67 [fn-name decorators & defn-stuff]
68 `(do
69 (defn ~fn-name ~@defn-stuff)
70 (alter-var-root (var ~fn-name) (reduce comp identity (reverse ~decorators)))
71 (var ~fn-name)))
72
73
74 (defn curry+
75 "another way to do it, curry+, thanks to duncant"
76 ([num-args f eval-list]
77 (if (= num-args (count eval-list))
78 (apply f eval-list)
79 (fn [& args]
80 (curry+ num-args f (concat eval-list args)))))
81 ([num-args f]
82 (curry+ num-args f '())))
83
84 (defn curry**
85 "curry classic. rlm. consumes stack like a mother"
86 [num-args f]
87 (fn [& args]
88 (let [num-inputs (count args)]
89 (if (= num-inputs num-args)
90 (apply f args)
91 (curry** (- num-args num-inputs)
92 (fn [& more] (apply f (concat args more))))))))
93
94 (defn curry++
95 "takes a function with a fixed number of args and modifies
96 it to that it will be automaticaly curried when called with
97 less args"
98 ([num-args f & eval-list]
99 (if (= num-args (count eval-list))
100 (apply f eval-list)
101 (fn [& args]
102 (apply curry++ num-args f (concat eval-list args))))))
103
104
105
106
107 (def curry* (curry++ 2 curry++))
108
109 (defn-decorated
110 curry
111 [(curry* 2)]
112 "higher order function that enables automatic curying as in haskel, scheme"
113 {:author "Robert McIntyre"}
114 [number-of-args f]
115 (curry++ number-of-args f))
116
117
118
119 ;;; Example of Use
120
121 (defn-decorated
122 demo
123 [memoize (curry 3)]
124 "I like the vector of unitarty higher order transforms ---
125 sort of like a list of modifiers on a magic(tm) card.
126 This function has flying, resistance to black, etc :)"
127 [a b c]
128 (println "side effect")
129 (+ a b c))
130
131
132 ;; (((((demo1)) 1) 2) 3)
133 ;; 6
134