;;; Системное программирование на Guile и пример использования
;;; потоков.  См. также реализацию ftw в Guile:
;;; https://git.savannah.gnu.org/cgit/guile.git/tree/module/ice-9/ftw.scm
;;;
;;; М. А. Крышень / Mikhail Kryshen <kryshen@cs.petrsu.ru>, 2019.
;;;
;;; Автор передает данную программу в общественное достояние, см.
;;; https://creativecommons.org/publicdomain/zero/1.0/

(use-modules (srfi srfi-41))

;; Упрощенный вариант POSIX ftw: proc вызывается с двумя аргументами —
;; путь и структура stat.  В случае любой ошибки выбрасывается
;; исключение (обход прерывается).  Обход прекращается, если proc
;; возвращает значение отличное от #t, это значение возвращается ftw.
(define (ftw path proc)
  (let* ((st (stat path))
         (ret (proc path st)))
    (if (and (eq? ret #t)
             (eq? (stat:type st) 'directory))
        (let ((dir (opendir path)))
          (let loop ((entry (readdir dir)))
            (cond
             ((eof-object? entry)
              (closedir dir)
              #t)
             ((member entry '("." ".."))
              (loop (readdir dir)))
             (else
              ;; Вместо string-append можно использовать
              ;; string-append/shared, тогда результирующая строка
              ;; может разделять память с исходыми, и proc не должна
              ;; применять к полученному пути деструктивные операции.
              (let* ((path (string-append path "/" entry))
                     (ret (ftw path proc)))
                (if (eq? ret #t)
                    (loop (readdir dir))
                    (begin
                      (closedir dir)
                      ret)))))))
        ret)))

;;; Вариант с использованием потоков.

;;; Обратите внимание, как потоки позволили разделить алгоритм обхода
;;; на процедуры: получение элементов каталога, фильтрация специальных
;;; имен, рекурсивный обход в глубину, и как императивный код,
;;; использующий opendir, readdir и closedir, изолирован в dir-stream,
;;; а dir-stream* и ftw-stream написаны в чисто функциональном стиле.

;; Возвращает поток элементов каталога.
(define-stream (dir-stream path)
  ;; Если выше использовать привычный define вместо define-stream,
  ;; opendir будет вызываться сразу при вызове dir-stream, а не при
  ;; получении первого элемента потока (define-stream откладывает
  ;; вычисление всего тела функции).
  (let ((dir (opendir path)))
    (let loop ((entry (readdir dir)))
      (if (eof-object? entry)
          (begin (closedir dir)
                 stream-null)
          (stream-cons entry (loop (readdir dir)))))))

;; Возвращает поток элементов каталога, исключая "." и "..".
(define (dir-stream* path)
  (stream-filter (λ (entry) (not (member entry '("." ".."))))
                 (dir-stream path)))

;; Поточный аналог ftw.  Возвращает поток элементов (путь stat),
;; получаемых при обходе дерева каталогов в глубину.
(define-stream (ftw-stream path)
  (let ((st (stat path)))
    (stream-cons
     (list path st)
     (if (eq? (stat:type st) 'directory)
         (stream-concat
          (stream-map
           (λ (entry)
             (ftw-stream (string-append path "/" entry)))
           (dir-stream* path)))
         stream-null))))

;; Альтернативная реализация ftw на основе ftw-stream.
(define (ftw* path proc)
  (define (loop strm)
    (if (stream-null? strm)
        #t
        (let ((ret (apply proc (stream-car strm))))
          (if (eq? ret #t)
              (loop (stream-cdr strm))
              ret))))
  (loop (ftw-stream path)))