an experimental procedure version of Gauche-process-notation

tmp.scm

(use util.match)
(use gauche.collection)
(use gauche.process)

(define (split-redirects rs)
  (define (input-redirect? x)
    (memq x '(< << <<< <&)))
  (define (output-redirect? x)
    (memq x '(> >> >&)))
  (fold2 (rec (retry r ins outs)
           (match r
             (((? input-redirect?) _fd _src)
              (values (cons r ins) outs))
             (((? output-redirect?) _fd _sink)
              (values ins (cons r outs)))
             (((? input-redirect? sym) src)
              (retry `(,sym 0 ,src) ins outs))
             (((? output-redirect? sym) sink)
              (retry `(,sym 1 ,sink) ins outs))
             (_
              (error "invalid redirection: " r))))
         '() '()
         rs))

(define (%run fork pf redirects)
  (receive (ins outs) (split-redirects redirects)
    (%%run fork pf ins outs)))

(define (%%run fork? pf ins outs)
  (define (split-pf xs)
    (fold3 (lambda (x cmd&args keys redirs)
             (match x
               (((? keyword?) arg)
                (values cmd&args (append! x keys) redirs))
               (((? symbol?) . rest)
                (values cmd&args keys (cons x redirs)))
               (_
                (values (cons x cmd&args) keys redirs))))
           '() '() '()
           (reverse xs)))
  (match pf
    (('^)
     (error "empty pipeline"))
    (('^ pf1)
     (%%run fork? pf1 ins outs))
    (('^ pf1 . rest)
     (let ((p (%%run #t pf1 ins '((> 1 stdout)))))
       (%%run fork? `(^ ,@rest) `((< 0 ,(process-output p))) outs)))
    (_
     (receive (cmd&args keys redirects) (split-pf pf)
       (let-keywords keys ((directory #f)
                           (sigmask #f)
                           (detached #f)
                           (host #f))
         (run-process cmd&args
                      :directory directory
                      :sigmask sigmask
                      :detached detached
                      :host host
                      :redirects (append ins outs redirects)
                      :fork fork?
                      :wait #f))))))

(define (run& pf . redirects)
  (%run #t pf redirects))

(define (run pf . redirects)
  (let ((p (apply run& pf redirects)))
    (process-wait p)
    (process-exit-status p)))

(define (run/port pf . redirects)
  (let ((p (apply run& pf '(> 1 stdout) redirects)))
    (process-output p)))

(define (run/strings pf . redirects)
  (port->list read-line (apply run/port pf redirects)))

(run '(echo foo))

(run '(grep "^cons" words
            (:directory "/usr/share/dict")))

(let ((url "http://www.example.org/licenses/gpl.txt"))
  (map (lambda (s)
         (call-with-input-string s
           (lambda (p)
             (let* ((n (read p))
                    (w (read p)))
               (cons w n)))))
       (run/strings
        `(^ (wget -O - ,url (> 2 :null))
           (tr -c "A-Za-z" "\n")
           (grep -v "^$")
           (tr "A-Z" "a-z")
           (sort)
           (uniq -c)
           (sort -rn)))))