source: project/release/4/combinators/trunk/generic-section-combinators.scm

Last change on this file was 34400, checked in by Kon Lovett, 4 years ago

re-flow

File size: 7.1 KB
Line 
1;;;; generic-section-combinators.scm
2;;;; Kon Lovett, Jul '10
3
4;; Issues
5;;
6;; !IN PROGRESS!
7
8(module generic-section-combinators
9
10(;export
11  left-hook-each right-hook-each
12  left-hook-each+ right-hook-each+
13  left-hook-argument-chain right-hook-argument-chain
14  left-hook-argument-chain+ right-hook-argument-chain+
15  fork-each fork-all
16  fork-each+ fork-all+)
17
18(import
19  (except scheme map)
20  chicken
21  (only data-structures identity)
22  (only srfi-1 circular-list map))
23
24(require-library data-structures srfi-1)
25
26(declare
27  (type
28    (left-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
29    (right-hook-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
30    (left-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
31    (right-hook-each+ (procedure (#!rest) (procedure (#!rest) *)))
32    (left-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
33    (right-hook-argument-chain (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
34    (left-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
35    (right-hook-argument-chain+ (procedure (#!rest) (procedure (#!rest) *)))
36    (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
37    (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
38    (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
39    (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
40
41(include "arguments-helpers.inc")
42
43;;; Hook
44
45(define (left-arguments-X . fns)
46  (lambda xs ((X-funcs (cons fns list)) xs)) )
47
48(define (right-arguments-X . fns)
49  (lambda xs ((X-funcs (cons list fns)) xs)) )
50
51#|
52?????
53(left-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X fn0 ... fnn list))
54(right-hook-X c fn0 ... fnn) = (arguments-chain c (arguments-X list fn0 ... fnn))
55|#
56
57;; left-hook-each
58
59; ((left-hook-each c f g) arg...) -> (apply c (f arg0) (g arg1) ... argn...)
60; ((left-hook-each c f) arg...) -> (apply c (f arg0) ... (f argn) arg...)
61; ((left-hook-each c) arg...) -> (apply c arg...)
62
63(define (left-hook-each c . fns)
64  (if (null? fns)
65    (lambda xs (apply c xs))
66    (let ((fn (each-func fns)))
67      (lambda xs (apply c (append (list (fn xs)) xs))) ) ) )
68
69;; right-hook-each
70
71; ((right-hook-each c f g) arg...) -> (apply c argn... (f arg0) (g arg1) ...)
72; ((right-hook-each c f) arg...) -> (apply c arg... (f arg0) ... (f argn))
73; ((right-hook-each c) arg...) -> (apply c arg...)
74
75(define (right-hook-each c . fns)
76  (if (null? fns)
77    (lambda xs (apply c xs))
78    (let ((fn (each-func fns)))
79      (lambda xs (apply c (append xs (list (fn xs))))) ) ) )
80
81;; left-hook-each+ a left-hook-each that curries it's functions
82
83; (left-hook-each+ c func...) -> (apply left-hook-each c func...)
84; (left-hook-each+ c) -> (lambda (func...) (apply left-hook-each+ c func...))
85; (left-hook-each+) -> (lambda (c) (left-hook-each+ c))
86
87(define (left-hook-each+ . fns)
88  (if (null? fns)
89    (lambda (c) (left-hook-each+ c))
90    (let ((c (car fns)) (fns (cdr fns)))
91      (if (null? fns)
92        (lambda fns (apply left-hook-each+ c fns))
93        (apply left-hook-each c fns) ) ) ) )
94
95;; right-hook-each+ a left-hook-each that curries it's functions
96
97; (right-hook-each+ c func...) -> (apply right-hook-each c func...)
98; (right-hook-each+ c) -> (lambda (func...) (apply right-hook-each+ c func...))
99; (right-hook-each+) -> (lambda (c) (right-hook-each+ c))
100
101(define (right-hook-each+ . fns)
102 (if (null? fns) (lambda (c)
103    (right-hook-each+ c))
104    (let ((c (car fns)) (fns (cdr fns)))
105      (if (null? fns)
106        (lambda fns (apply right-hook-each+ c fns))
107        (apply right-hook-each c fns) ) ) ) )
108
109;; left-hook-argument-chain
110
111; ((left-hook-argument-chain c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)
112; ((left-hook-argument-chain c f) arg...) -> (apply c (apply f arg...) arg...)
113; ((left-hook-argument-chain c) arg...) -> (apply c arg...)
114
115(define (left-hook-argument-chain c . fns)
116  (let ((c (car fns))
117        (fns (cdr fns)) )
118    (if (null? fns)
119      (lambda xs (apply c xs))
120      (lambda xs (apply c (chain-recur fns xs) xs)) ) ) )
121
122;; right-hook-argument-chain
123
124; ((right-hook-argument-chain c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))
125; ((right-hook-argument-chain c f) arg...) -> (apply c arg... (apply f arg...))
126; ((right-hook-argument-chain c) arg...) -> (apply c arg...)
127
128(define (right-hook-argument-chain c . fns)
129  (let ((c (car fns))
130        (fns (cdr fns)) )
131    (if (null? fns)
132      (lambda xs (apply c xs))
133      (lambda xs (apply c (append xs (list (chain-recur fns xs))))) ) ) )
134
135;; left-hook-argument-chain+ a left-hook-argument-chain that curries it's functions
136
137; (left-hook-argument-chain+ c func...) -> (apply left-hook-argument-chain c func...)
138; (left-hook-argument-chain+ c) -> (lambda (func...) (apply left-hook-argument-chain+ c func...))
139; (left-hook-argument-chain+) -> (lambda (c) (left-hook-argument-chain+ c))
140
141(define (left-hook-argument-chain+ . fns)
142  (if (null? fns)
143    (lambda (c) (left-hook-argument-chain+ c))
144    (let ((c (car fns)) (fns (cdr fns)))
145      (if (null? fns)
146        (lambda fns (apply left-hook-argument-chain+ c fns))
147        (apply left-hook-argument-chain c fns) ) ) ) )
148
149;; right-hook-argument-chain+ a right-hook-argument-chain that curries it's functions
150
151; (right-hook-argument-chain+ c func...) -> (apply right-hook-argument-chain c func...)
152; (right-hook-argument-chain+ c) -> (lambda (func...) (apply right-hook-argument-chain+ c func...))
153; (right-hook-argument-chain+) -> (lambda (c) (right-hook-argument-chain+ c))
154
155(define (right-hook-argument-chain+ . fns)
156 (if (null? fns)
157    (lambda (c) (right-hook-argument-chain+ c))
158    (let ((c (car fns)) (fns (cdr fns)))
159      (if (null? fns)
160        (lambda fns (apply right-hook-argument-chain+ c fns))
161        (apply right-hook-argument-chain c fns) ) ) ) )
162
163;;; Fork
164
165;; fork-each
166
167; (fork-each c func...) -> (lambda xs (apply c (apply (apply arguments-each func...) xs)))
168
169(define (fork-each c . fns)
170  (let ((fn (each-func fns)))
171    (lambda xs (apply c (fn xs))) ) )
172
173;; fork-all
174
175; (fork-all c func...) -> (lambda xs (apply c (apply (apply arguments-all func...) xs)))
176
177(define (fork-all c . fns)
178  (let ((fn (all-func fns)))
179    (lambda xs (apply c (fn xs))) ) )
180
181;; fork-each+ a fork-each that curries it's functions
182
183; (fork-each+ c func...) -> (apply fork-each c func...)
184; (fork-each+ c) -> (lambda (func...) (apply fork-each+ c func...))
185; (fork-each+) -> (lambda (c) (fork-each+ c))
186
187(define (fork-each+ . fns)
188  (if (null? fns)
189    (lambda (c) (fork-each+ c))
190    (let ((c (car fns)) (fns (cdr fns)))
191      (if (null? fns)
192        (lambda fns (apply fork-each+ c fns))
193        (apply fork-each c fns) ) ) ) )
194
195;; fork-all+ a fork-all that curries it's functions
196
197; (fork-all+ c func...) -> (apply fork-all c func...)
198; (fork-all+ c) -> (lambda (func...) (apply fork-all+ c func...))
199; (fork-all+) -> (lambda (c) (fork-all+ c))
200
201(define (fork-all+ . fns)
202  (if (null? fns)
203    (lambda (c) (fork-all+ c))
204    (let ((c (car fns)) (fns (cdr fns)))
205      (if (null? fns)
206        (lambda fns (apply fork-all+ c fns))
207        (apply fork-all c fns) ) ) ) )
208
209) ;module generic-section-combinators
Note: See TracBrowser for help on using the repository browser.