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

;;;; generic-section-combinators.scm
;;;; Kon Lovett, Jul '10

(module generic-section-combinators

  (;export
    o-with-apply
    left-hook right-hook
    argument-each argument-all
    fork-each fork-all)

  (import
    (except scheme map)
    chicken
    (only data-structures identity)
    (only srfi-1 circular-list map))

  (require-library data-structures srfi-1)

  (declare
    (type
      (o-with-apply (procedure (#!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 (#!rest) (procedure (#!rest) *)))
      (fork-all+ (procedure (#!rest) (procedure (#!rest) *))) ))

;;; Hook

;;l Helpers

(define-inline (hook-recur fns xs)
  ; assume the length of fns is << so recursion depth is also <<
  (let recur ((fns fns))
    (if (null? fns) xs
      (apply (car fns) (recur (cdr fns))) ) ) )

(define-inline (hook-recur+ g fns xs)
  (apply g (hook-recur fns xs)) )

;; o-with-apply

; ((o-with-apply f g) arg...) -> (apply f (apply g arg...))
; ((o-with-apply f) arg...) -> (apply f arg...)
; ((o-with-apply) arg...) -> (list arg...)

(define (o-with-apply . fns)
  ; 0
  (if (null? fns) list
    (let ((f (car fns))
          (fns (cdr fns)) )
      ; 1
      (if (null? fns) (lambda xs (apply f xs))
        ; > 1
        (lambda xs (hook-recur+ f fns xs)) ) ) ) )

;; left-hook

; ((left-hook c f g) arg...) -> (apply c (apply f (apply g arg...)) arg...)
; ((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)) ) ) ) )

;; right-hook

; ((right-hook c f g) arg...) -> (apply c arg... (apply f (apply g arg...)))
; ((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))))) ) ) ) )

;;; Argument

;; Helpers

(define-inline (argument-each-func fns)
  (cond
    ((null? fns)
      identity )
    ((null? (cdr fns))
      (lambda (xs) (map (cute (car fns) <>) xs)) )
    (else
      (let ((fns (apply circular-list fns)))
        (lambda (xs) (map (cut <> <>) fns xs)) ) ) ) )

(define-inline (argument-all-funcs fns)
  (cond
    ((null? fns)
      identity )
    ((null? (cdr fns))
      (lambda (xs) (list (apply (car fns) xs))) )
    (else
      (lambda (xs) (map (cut apply <> xs) fns)) ) ) )

;; argument-each

; ((argument-each f g h) a b c d e) -> (list (f a) (g b) (h c) (f d) (g e))
; ((argument-each) arg...) -> (list arg...)

(define (argument-each . fns)
  (let ((fn (argument-each-func fns)))
    (lambda xs (fn xs)) ) )

;; argument-all

; ((argument-all f g h) a b c) -> (list (f a b c) (g a b c) (h a b c))
; ((argument-all) arg...) -> (list arg...)

(define (argument-all . fns)
  (let ((fn (argument-all-func fns)))
    (lambda xs (fn xs)) ) )

;;; Fork

;; fork-each

; (fork-each c func...) -> (lambda xs (apply c (apply (apply argument-each func...) xs)))

(define (fork-each c . fns)
  (let ((fn (argument-each-func fns)))
    (lambda xs (apply c (fn xs))) ) )

;; fork-all

; (fork-all c func...) -> (lambda xs (apply c (apply (apply argument-all func...) xs)))

(define (fork-all c . fns)
  (let ((fn (argument-all-func fns)))
    (lambda xs (apply c (fn xs))) ) )

;; 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))

(define (fork-each+ . fns)
  (if (null? fns) (lambda (c) (fork-each+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply fork-each+ c fns))
        (apply fork-each c fns) ) ) ) )

;; 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))

(define (fork-all+ . fns)
  (if (null? fns) (lambda (c) (fork-all+ c))
    (let ((c (car fns)) (fns (cdr fns)))
      (if (null? fns) (lambda fns (apply fork-all+ c fns))
        (apply fork-all c fns) ) ) ) )

) ;module generic-section-combinators