Changeset 18947 in project

Timestamp:

07/24/10 04:16:17 (11 years ago)

Author:

Kon Lovett

Message:

hook+ added

File:

• release/4/combinators/trunk/generic-section-combinators.scm (modified) (6 diffs)

release/4/combinators/trunk/generic-section-combinators.scm

@@ -7 +7 @@
     o-with-apply
     left-hook right-hook
+    left-hook+ right-hook+
     argument-each argument-all
-    fork-each fork-all)
+    fork-each fork-all
+    fork-each+ fork-all+)
 
   (import
@@ -21 +23 @@
     (type
       (o-with-apply (procedure (#!rest) (procedure (#!rest) *)))
-      (left-hook (procedure (#!rest) (procedure (#!rest) *)))
-      (right-hook (procedure (#!rest) (procedure (#!rest) *)))
+      (left-hook (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
+      (right-hook (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
+      (left-hook+ (procedure (#!rest) (procedure (#!rest) *)))
+      (right-hook+ (procedure (#!rest) (procedure (#!rest) *)))
       (argument-each (procedure (#!rest) (procedure (#!rest) list)))
       (argument-all (procedure (#!rest) (procedure (#!rest) list)))
+      (fork-each (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
+      (fork-all (procedure ((procedure (#!rest) *) #!rest) (procedure (#!rest) *)))
       (fork-each+ (procedure (#!rest) (procedure (#!rest) *)))
       (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))
@@ -62 +68 @@
 ; ((left-hook c f) arg...) -> (apply c (apply f arg...) arg...)
 ; ((left-hook c) arg...) -> (apply c arg...)
-; ((left-hook) arg...) -> (list arg...)
 
-(define (left-hook . fns)
-  ; 0
-  (if (null? fns) list
-    (let ((c (car fns))
-          (fns (cdr fns)) )
-      ; 1
-      (if (null? fns) (lambda xs (apply c xs))
-        ; > 1
-        (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) ) )
+(define (left-hook c . fns)
+  (let ((c (car fns))
+        (fns (cdr fns)) )
+    (if (null? fns) (lambda xs (apply c xs))
+      (lambda xs (apply c (hook-recur+ (car fns) (cdr fns) xs) xs)) ) ) )
 
 ;; right-hook
@@ -79 +80 @@
 ; ((right-hook c f) arg...) -> (apply c arg... (apply f arg...))
 ; ((right-hook c) arg...) -> (apply c arg...)
-; ((right-hook) arg...) -> (list arg...)
 
-(define (right-hook . fns)
-  ; 0
-  (if (null? fns) list
-    (let ((c (car fns))
-          (fns (cdr fns)) )
-      ; 1
-      (if (null? fns) (lambda xs (apply c xs))
-        ; > 1
-        (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) ) )
+(define (right-hook c . fns)
+  (let ((c (car fns))
+        (fns (cdr fns)) )
+    (if (null? fns) (lambda xs (apply c xs))
+      (lambda xs (apply c (append xs (list (hook-recur+ (car fns) (cdr fns) xs))))) ) ) )
+
+;; left-hook+
+
+; (left-hook+ c func...) -> (apply left-hook c func...)
+; (left-hook+ c) -> (lambda (func...) (apply left-hook+ c func...))
+; left-hook+) -> (lambda (c) (left-hook+ c))
+
+(define (left-hook+ . fns)
+  (if (null? fns) (lambda (c) (left-hook+ c))
+    (let ((c (car fns)) (fns (cdr fns)))
+      (if (null? fns) (lambda fns (apply left-hook+ c fns))
+        (apply left-hook c fns) ) ) ) )
+
+;; right-hook+
+
+; (right-hook+ c func...) -> (apply right-hook c func...)
+; (right-hook+ c) -> (lambda (func...) (apply right-hook+ c func...))
+; right-hook+) -> (lambda (c) (right-hook+ c))
+
+(define (right-hook+ . fns)
+ (if (null? fns) (lambda (c) (right-hook+ c))
+    (let ((c (car fns)) (fns (cdr fns)))
+      (if (null? fns) (lambda fns (apply right-hook+ c fns))
+        (apply right-hook c fns) ) ) ) )
 
 ;;; Argument
@@ -152 +172 @@
 ;; fork-each+ a fork-each that curries it's functions
 
-; (fork-each+ c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs)))
-; (fork-each+ c) -> (lambda funcs (apply fork-each c funcs))
-; (fork-each+) -> (lambda (c) (fork-each c))
+; (fork-each+ c func...) -> (apply fork-each c func...)
+; (fork-each+ c) -> (lambda (func...) (apply fork-each+ c func...))
+; (fork-each+) -> (lambda (c) (fork-each+ c))
 
 (define (fork-each+ . fns)
@@ -164 +184 @@
 ;; fork-all+ a fork-all that curries it's functions
 
-; (fork-all+ c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs)))
-; (fork-all+ c) -> (lambda funcs (apply fork-all c funcs))
-; (fork-all+) -> (lambda (c) (fork-all c))
+; (fork-all+ c func...) -> (apply fork-all c func...)
+; (fork-all+ c) -> (lambda (func...) (apply fork-all+ c func...))
+; (fork-all+) -> (lambda (c) (fork-all+ c))
 
 (define (fork-all+ . fns)