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

Last change on this file since 18947 was 18947, checked in by Kon Lovett, 10 years ago

hook+ added

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