Add pipeline semantics

* geesh/shell.scm (swap-and-shift-pairs): New function.
(make-pipes): New function.
(plumb): New function.
(sh:pipeline): New public function.
* tests/shell.scm: Test it.

geesh/shell.scm

@@ -7,6 +7,7 @@
   #:use-module (srfi srfi-26)
   #:export (sh:exec-let
             sh:exec
+            sh:pipeline
             sh:subshell
             sh:substitute-command
             sh:with-redirects))
@@ -211,3 +212,58 @@ a string."
                 ((pid . status) (waitpid pid)))
       (set-var! env "?" (number->string (status:exit-val status)))
       result)))
+
+
+;;; Pipelines.
+
+(define (swap-and-shift-pairs pairs)
+  "Swap and shift @var{pairs} over by one.  For example, the list
+@code{((a . b) (c . d))} becomes @code{((#f . b) (a . d) (c . #f))}"
+  (let ((kons (lambda (pair acc)
+                (match-let (((a . b) pair))
+                  (match acc
+                    ((head . rest) `(,b (,a . ,head) ,@rest))
+                    (() `(,b (,a . #f))))))))
+    (match (fold-right kons '() pairs)
+      ((head . rest) `((#f . ,head) ,@rest))
+      (() '()))))
+
+(define (make-pipes xs)
+  "Cons each element of @var{xs} to a pair of ports such that the first
+port is an input port connected to the second port of the previous
+element's pair, and the second port is an output port connected to the
+first port of next element's pair.  The first pair will have @code{#f}
+for an input port and the last will have @code{#f} as an output port."
+  (match xs
+    (() '())
+    ((x) `((,x . (#f . #f))))
+    (_ (let ((pipes (map (lambda (x) (pipe)) (cdr xs))))
+         (map cons xs (swap-and-shift-pairs pipes))))))
+
+(define (plumb env in out thunk)
+  "Run @var{thunk} in a new process with @code{current-input-port} set
+to @var{in} and @code{current-output-port} set to @var{out}.  If
+@var{in} or @var{out} is @code{#f}, the corresponding ``current'' port
+is left unchanged."
+  (let* ((thunk* (lambda ()
+                   (let ((in (or in (current-input-port)))
+                         (out (or out (current-output-port))))
+                     (parameterize ((current-input-port in)
+                                    (current-output-port out))
+                       (thunk)))))
+         (pid (%subshell thunk*)))
+    (when in (close-port in))
+    (when out (close-port out))
+    pid))
+
+(define (sh:pipeline env . thunks)
+  "Run each thunk in @var{thunks} in its own process with the output
+of each thunk sent to the input of the next thunk."
+  (let ((pids (map (match-lambda
+                     ((thunk . (source . sink))
+                      (plumb env source sink thunk)))
+                   (make-pipes thunks))))
+    (unless (null? pids)
+      (match-let* ((pid (last pids))
+                   ((pid . status) (waitpid pid)))
+        (set-var! env "?" (number->string (status:exit-val status)))))))

tests/shell.scm

@@ -442,4 +442,81 @@
   (let ((env (make-environment '())))
     (sh:substitute-command env noop)))
 
+
+;; Pipelines.
+
+(test-equal "Built-ins are connected by pipelines"
+  "foo"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let ((foo (string-append directory "/foo.txt"))
+           (env (make-environment '())))
+       (sh:pipeline env
+                    (lambda ()
+                      (display "foo\n"))
+                    (lambda ()
+                      (with-output-to-file foo
+                        (lambda ()
+                          (display (get-line (current-input-port)))))))
+       (call-with-input-file foo get-string-all)))))
+
+(test-equal "External utilities are connected by pipelines"
+  "foo"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let ((utility1 (string-append directory "utility1"))
+           (utility2 (string-append directory "utility2"))
+           (foo (string-append directory "/foo.txt"))
+           (env (make-environment '())))
+       (make-script utility1
+         (display "foo\n"))
+       (make-script utility2
+         (use-modules (ice-9 textual-ports))
+         (with-output-to-file ,foo
+           (lambda ()
+             (display (get-line (current-input-port))))))
+       (sh:pipeline env
+                    (lambda ()
+                      (sh:exec env utility1))
+                    (lambda ()
+                      (sh:exec env utility2)))
+       (call-with-input-file foo get-string-all)))))
+
+(test-equal "Externals and built-ins are connected by pipelines"
+  "foo"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let ((utility (string-append directory "/utility"))
+           (foo (string-append directory "/foo.txt"))
+           (env (make-environment '())))
+       (make-script utility
+         (display "foo\n"))
+       (sh:pipeline env
+                    (lambda ()
+                      (sh:exec env utility))
+                    (lambda ()
+                      (with-output-to-file foo
+                        (lambda ()
+                          (display (get-line (current-input-port)))))))
+       (call-with-input-file foo get-string-all)))))
+
+(test-equal "Built-ins and externals are connected by pipelines"
+  "foo"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let ((utility (string-append directory "/utility"))
+           (foo (string-append directory "/foo.txt"))
+           (env (make-environment '())))
+       (make-script utility
+         (use-modules (ice-9 textual-ports))
+         (with-output-to-file ,foo
+           (lambda ()
+             (display (get-line (current-input-port))))))
+       (sh:pipeline env
+                    (lambda ()
+                      (display "foo\n"))
+                    (lambda ()
+                      (sh:exec env utility)))
+       (call-with-input-file foo get-string-all)))))
+
 (test-end)