;;;;;; Folding enumerators for ports & file systems      -*- Scheme -*-

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; (PORT-FOLD <f> <reader> <port> <initial-seed> ...) -> [seed' ...]
;;;     (READER <port>) -> elt
;;;     (F <elt> <seed> ...) -> [proceed? seed' ...]
;;;   PORT-FOLD is the general port input folder; it folds the elements
;;;   of input from PORT as read by READER with F, starting with the
;;;   given initial seeds.
(define (port-fold f read port . initial-seeds)
  (%fold (lambda (sk fk)
           (let ((elt (read port)))
             (if (eof-object? elt)
                 (fk)
                 (sk elt))))
         f initial-seeds))

;;; Utility for constructing specialized port folders.
(define (port-folder read)              ; Integrate me...
  (lambda (f port . initial-seeds)
    (%fold (lambda (sk fk)
             (let ((elt (read port)))
               (if (eof-object? elt)
                   (fk)
                   (sk elt))))
           f initial-seeds)))

;;; (FOLD-INPUT-<elt> <f> <port> <initial-seed> ...) -> [seed' ...]
;;;     (F <elt> <seed> ...) -> [proceed? seed' ...]
;;;   Port input folders for specific elements:
;;;       - FOLD-INPUT-CHARS reads single characters.
;;;       - FOLD-INPUT-LINES reads lines, delimited by line feeds (LF).
;;;       - FOLD-INPUT-SEXPS reads S-expressions with READ.
(define fold-input-chars (port-folder read-char))
(define fold-input-lines (port-folder read-line))
(define fold-input-sexps (port-folder read))

;;; (FOLD-INPUT-STRINGS <f> <port> <bufsize> <initial-seed> ...)
;;;       -> [seed' ...]
;;;     (F <buffer> <filled-size> <seed> ...) -> [proceed? seed' ...]
;;;   Block port input folder.  For each subsequent block of input of
;;;   BUFSIZE characters, F is applied to a string of length BUFSIZE --
;;;   which it should use downward-only; that is, it shouldn't store it
;;;   in data structures without copying it --, and the number of
;;;   characters that were successfully read in that block.  Beyond the
;;;   specified number of characters, the contents of the string are
;;;   unspecified.
;;;
;;; (This ought to operate directly on the port's buffer.  Oh well.)
(define (fold-input-strings f port size . initial-seeds)
  (let ((buffer (make-string size)))
    (%fold (lambda (sk fk)
             (let ((maybe-chars-read (read-string! buffer port)))
               (if (or (not         maybe-chars-read)
                       (eof-object? maybe-chars-read)                ;?
                       (zero?       maybe-chars-read))
                   (fk)
                   (sk (if (= maybe-chars-read size)
                           #f
                           maybe-chars-read)))))
           (lambda (maybe-chars-read . seeds)
             (apply f buffer maybe-chars-read seeds))
           initial-seeds)))



;;; (DIRECTORY-FOLD <f> <directory-filename> <initial-seed> ...)
;;;       -> [seed' ...]
;;;     (F <filename> <seed> ...) -> [proceed? seed' ...]
;;;   Fold the set of filenames contained in the directory named by
;;;   DIRECTORY-FILENAME with F.  DIRECTORY-FILENAME is prepended to
;;;   each filename passed to F.
(define (directory-fold f dir . initial-seeds)
  (let* ((dir (directory-as-file-name dir))
         (stream (open-directory-stream dir)))
    (receive final-seeds
        (%fold (lambda (sk fk)
                 (cond ((read-directory-stream stream)
                        => (lambda (file)
                             (sk (string-append dir "/" file))))
                       (else (fk))))
               f initial-seeds)
      (close-directory-stream stream)
      (apply values final-seeds))))

;;; (DIRECTORY-TREE-FOLD <f> <directory-filename> <initial-seed> ...)
;;;       -> [seed' ...]
;;;     (F <filename> <seed> ...)
;;;           -> [proceed-down? proceed-across? seed' ...]
;;;   Like DIRECTORY-FOLD, but perform the folding recursively down an
;;;   entire tree of directories.  F may halt the recursive processing
;;;   down by returning #F for PROCEED-DOWN?; it may halt the forward
;;;   processing in a single directory by returning PROCEED-ACROSS? as
;;;   #F.  A true value for PROCEED-DOWN? will cause further recursive
;;;   searching, and a true value for PROCEED-ACROSS? will continue the
;;;   folding across the current subdirectory's files.  There is
;;;   currently no way to prematurely terminate the entire recursive
;;;   folding operation.
(define (directory-tree-fold f dir . initial-seeds)
  (let recur ((dir dir) (seeds initial-seeds))
    (apply directory-fold
           (lambda (file . seeds)
             (receive (proceed-down? proceed-across? . new-seeds)
                 (apply f file seeds)
               (if (and proceed-down? (file-directory? file))
                   (receive new-seeds* (recur file new-seeds)
                     (apply values proceed-across? new-seeds*))
                   (apply values proceed-across? new-seeds))))
           dir seeds)))



;;; Auxiliary for general folding based on imperative readers in CPS.
(define (%fold read f initial-seeds)
  (let loop ((seeds initial-seeds))
    (read (lambda () (apply values initial-seeds))
          (lambda (elt)
            (receive (proceed? . new-seeds)
                (apply f elt seeds)
              (if proceed?
                  (loop new-seeds)
                  (apply values new-seeds)))))))