source: project/release/4/combinators/tags/1.2.0/generic-section-combinators.scm @ 19029

Last change on this file since 19029 was 19029, checked in by Kon Lovett, 9 years ago

Release w/ more stuff.

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