fantasy-vacation-planner/lib/filesystem.scm

(library (lib filesystem)
  (export exists?
          existing-readable?
          directory?
          get-files-from-directory)
  (import
    (except (rnrs base) let-values)
    (only (guile)
          lambda* λ
          ;; exceptions
          raise-exception make-exception
          ;; file system
          access?
          stat stat:type
          F_OK R_OK
          )
    (ice-9 exceptions)
    (ice-9 ftw)
    (ice-9 match)

    (srfi srfi-1)

    (fslib)

    (lib string-procs)
    (lib list-procs)
    (prefix (lib logger) log:)))


(define exists?
  (λ (location)
    (access? location F_OK)))


(define existing-readable?
  (λ (location)
    (access? location R_OK)))


(define get-file-system-item-type
  (λ (location)
    (stat:type (stat location))))


(define directory?
  (λ (location)
    (symbol=? (get-file-system-item-type location)
              'directory)))


(define file?
  (λ (location)
    (symbol=? (get-file-system-item-type location)
              'regular)))

;; From: https://www.gnu.org/software/guile/manual/html_node/File-Tree-Walk.html
(define remove-stat
  ;; Remove the `stat' object the `file-system-tree' provides
  ;; for each file in the tree.
  (match-lambda
    [(name stat)              ; flat file
     name]
    [(name stat children ...) ; directory
     (list name (map remove-stat children))]))


(define get-files-from-directory
  (lambda* (directory-location
            #:key
            (filter-proc (λ (fname) #t)))
    ;; todo 1: check if directory-location really points to a
    ;; directory.
    (let ([stat-result (stat directory-location)]
          [actual-filter-proc
           (λ (fname)
             (and (not (string=? fname "."))
                  (not (string=? fname ".."))
                  (file? (fsing-join directory-location fname))
                  (filter-proc fname)))])
      (cond
       [(directory? directory-location)
        (filter actual-filter-proc
                (scandir directory-location))]
       [else
        (raise-exception
         (make-exception
          (make-non-continuable-error)
          (make-exception-with-message "not a directory")
          (make-exception-with-irritants directory-location)
          (make-exception-with-origin 'get-files-from-directory)))]))))