1 | ;;;; generic-section-combinators.scm |
---|
2 | ;;;; Kon Lovett, Jul '10 |
---|
3 | |
---|
4 | (module generic-section-combinators |
---|
5 | |
---|
6 | (;export |
---|
7 | o-with-apply |
---|
8 | left-hook right-hook |
---|
9 | argument-each argument-all |
---|
10 | fork-each fork-all) |
---|
11 | |
---|
12 | (import |
---|
13 | (except scheme map) |
---|
14 | chicken |
---|
15 | (only data-structures identity) |
---|
16 | (only srfi-1 circular-list map)) |
---|
17 | |
---|
18 | (require-library data-structures srfi-1) |
---|
19 | |
---|
20 | (declare |
---|
21 | (type |
---|
22 | (o-with-apply (procedure (#!rest) (procedure (#!rest) *))) |
---|
23 | (left-hook (procedure (#!rest) (procedure (#!rest) *))) |
---|
24 | (right-hook (procedure (#!rest) (procedure (#!rest) *))) |
---|
25 | (argument-each (procedure (#!rest) (procedure (#!rest) list))) |
---|
26 | (argument-all (procedure (#!rest) (procedure (#!rest) list))) |
---|
27 | (fork-each+ (procedure (#!rest) (procedure (#!rest) *))) |
---|
28 | (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) )) |
---|
29 | |
---|
30 | ;;; Hook |
---|
31 | |
---|
32 | ;;l Helpers |
---|
33 | |
---|
34 | (define-inline (hook-recur fns xs) |
---|
35 | ; assume the length of fns is << so recursion depth is also << |
---|
36 | (let recur ((fns fns)) |
---|
37 | (if (null? fns) xs |
---|
38 | (apply (car fns) (recur (cdr fns))) ) ) ) |
---|
39 | |
---|
40 | (define-inline (hook-recur+ g fns xs) |
---|
41 | (apply g (hook-recur fns xs)) ) |
---|
42 | |
---|
43 | ;; o-with-apply |
---|
44 | |
---|
45 | ; ((o-with-apply f g) arg...) -> (apply f (apply g arg...)) |
---|
46 | ; ((o-with-apply f) arg...) -> (apply f arg...) |
---|
47 | ; ((o-with-apply) arg...) -> (list arg...) |
---|
48 | |
---|
49 | (define (o-with-apply . fns) |
---|
50 | ; 0 |
---|
51 | (if (null? fns) list |
---|
52 | (let ((f (car fns)) |
---|
53 | (fns (cdr fns)) ) |
---|
54 | ; 1 |
---|
55 | (if (null? fns) (lambda xs (apply f xs)) |
---|
56 | ; > 1 |
---|
57 | (lambda xs (hook-recur+ f fns xs)) ) ) ) ) |
---|
58 | |
---|
59 | ;; left-hook |
---|
60 | |
---|
61 | ; ((left-hook c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...) |
---|
62 | ; ((left-hook c f) arg...) -> (apply c (apply f arg...) arg...) |
---|
63 | ; ((left-hook c) arg...) -> (apply c arg...) |
---|
64 | ; ((left-hook) arg...) -> (list arg...) |
---|
65 | |
---|
66 | (define (left-hook . fns) |
---|
67 | ; 0 |
---|
68 | (if (null? fns) list |
---|
69 | (let ((c (car fns)) |
---|
70 | (fns (cdr fns)) ) |
---|
71 | ; 1 |
---|
72 | (if (null? fns) (lambda xs (apply c xs)) |
---|
73 | ; > 1 |
---|
74 | (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) ) ) |
---|
75 | |
---|
76 | ;; right-hook |
---|
77 | |
---|
78 | ; ((right-hook c f g) arg...) -> (apply c arg... (apply f (apply g arg...))) |
---|
79 | ; ((right-hook c f) arg...) -> (apply c arg... (apply f arg...)) |
---|
80 | ; ((right-hook c) arg...) -> (apply c arg...) |
---|
81 | ; ((right-hook) arg...) -> (list arg...) |
---|
82 | |
---|
83 | (define (right-hook . fns) |
---|
84 | ; 0 |
---|
85 | (if (null? fns) list |
---|
86 | (let ((c (car fns)) |
---|
87 | (fns (cdr fns)) ) |
---|
88 | ; 1 |
---|
89 | (if (null? fns) (lambda xs (apply c xs)) |
---|
90 | ; > 1 |
---|
91 | (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) ) ) |
---|
92 | |
---|
93 | ;;; Argument |
---|
94 | |
---|
95 | ;; Helpers |
---|
96 | |
---|
97 | (define-inline (argument-each-func fns) |
---|
98 | (cond |
---|
99 | ((null? fns) |
---|
100 | identity ) |
---|
101 | ((null? (cdr fns)) |
---|
102 | (lambda (xs) (map (cute (car fns) <>) xs)) ) |
---|
103 | (else |
---|
104 | (let ((fns (apply circular-list fns))) |
---|
105 | (lambda (xs) (map (cut <> <>) fns xs)) ) ) ) ) |
---|
106 | |
---|
107 | (define-inline (argument-all-funcs fns) |
---|
108 | (cond |
---|
109 | ((null? fns) |
---|
110 | identity ) |
---|
111 | ((null? (cdr fns)) |
---|
112 | (lambda (xs) (list (apply (car fns) xs))) ) |
---|
113 | (else |
---|
114 | (lambda (xs) (map (cut apply <> xs) fns)) ) ) ) |
---|
115 | |
---|
116 | ;; argument-each |
---|
117 | |
---|
118 | ; ((argument-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e)) |
---|
119 | ; ((argument-each) arg...) -> (list arg...) |
---|
120 | |
---|
121 | (define (argument-each . fns) |
---|
122 | (let ((fn (argument-each-func fns))) |
---|
123 | (lambda xs (fn xs)) ) ) |
---|
124 | |
---|
125 | ;; argument-all |
---|
126 | |
---|
127 | ; ((argument-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c)) |
---|
128 | ; ((argument-all) arg...) -> (list arg...) |
---|
129 | |
---|
130 | (define (argument-all . fns) |
---|
131 | (let ((fn (argument-all-func fns))) |
---|
132 | (lambda xs (fn xs)) ) ) |
---|
133 | |
---|
134 | ;;; Fork |
---|
135 | |
---|
136 | ;; fork-each |
---|
137 | |
---|
138 | ; (fork-each c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs))) |
---|
139 | |
---|
140 | (define (fork-each c . fns) |
---|
141 | (let ((fn (argument-each-func fns))) |
---|
142 | (lambda xs (apply c (fn xs))) ) ) |
---|
143 | |
---|
144 | ;; fork-all |
---|
145 | |
---|
146 | ; (fork-all c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs))) |
---|
147 | |
---|
148 | (define (fork-all c . fns) |
---|
149 | (let ((fn (argument-all-func fns))) |
---|
150 | (lambda xs (apply c (fn xs))) ) ) |
---|
151 | |
---|
152 | ;; fork-each+ a fork-each that curries it's functions |
---|
153 | |
---|
154 | ; (fork-each+ c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs))) |
---|
155 | ; (fork-each+ c) -> (lambda funcs (apply fork-each c funcs)) |
---|
156 | ; (fork-each+) -> (lambda (c) (fork-each c)) |
---|
157 | |
---|
158 | (define (fork-each+ . fns) |
---|
159 | (if (null? fns) (lambda (c) (fork-each+ c)) |
---|
160 | (let ((c (car fns)) (fns (cdr fns))) |
---|
161 | (if (null? fns) (lambda fns (apply fork-each+ c fns)) |
---|
162 | (apply fork-each c fns) ) ) ) ) |
---|
163 | |
---|
164 | ;; fork-all+ a fork-all that curries it's functions |
---|
165 | |
---|
166 | ; (fork-all+ c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs))) |
---|
167 | ; (fork-all+ c) -> (lambda funcs (apply fork-all c funcs)) |
---|
168 | ; (fork-all+) -> (lambda (c) (fork-all c)) |
---|
169 | |
---|
170 | (define (fork-all+ . fns) |
---|
171 | (if (null? fns) (lambda (c) (fork-all+ c)) |
---|
172 | (let ((c (car fns)) (fns (cdr fns))) |
---|
173 | (if (null? fns) (lambda fns (apply fork-all+ c fns)) |
---|
174 | (apply fork-all c fns) ) ) ) ) |
---|
175 | |
---|
176 | ) ;module generic-section-combinators |
---|