directory-tree.rkt

#lang racket

(define (string-empty? str)
  (= (string-length str) 0))

(define (file-name-as-string fn)
  (cond
    ((path? fn) (path->string fn))
    ((string? fn) fn)
    (else (error "Unkonwn type!"))))

(define (list-subdirectories path)
  (define (is-directory fn)
    (if (null? fn)
        #f
        (directory-exists? (build-path path fn))))
  (define (is-regular fn)
    (if (null? fn)
        #f
        (and (not (link-exists? (build-path path fn))) (not (regexp-match #rx"^\\." fn)))))
  (define (filt fn)
    (and (is-regular fn) (is-directory fn)))
  (filter filt (directory-list path)))

(define (list-files path
                    #:basename (basename #t))
  (define (file-name-without-extension file)
    (let
        ((fn (file-name-as-string file)))
      (if (string-empty? fn)
          '()
          (car (regexp-split #rx"\\.(?=[^.]*$)" fn)))))
  (define (is-regular fn)
    (if (null? fn)
        #f
        (and (file-exists? (build-path path fn)) (not (regexp-match #rx"^\\." fn)))))
  (define (transform-filename fn)
    (if basename
        (file-name-without-extension fn)
        (file-name-from-path fn)))
  (map transform-filename (filter is-regular (directory-list path))))

(define (walk-directory path
                        #:title (title "")
                        #:basename (basename #t))
  (let* ((content (directory-list path))
         (directories (list-subdirectories path))
         (files (list-files path #:basename basename)))
    (cons (if (string-empty? title) path title)
          (append
           (map
            (lambda (entry)
              (walk-directory (build-path path entry) #:basename basename))
            directories)
           files))))

(define (print-node node (prefix ""))
  (display prefix)
  (display node)
  (newline))

(define (print-tree tree
                    #:prefix (prefix "")
                    #:root (root #f))
  (unless (null? tree)
    (let ((first-node (car tree))
          (last-node (last tree)))
      (define (is-first-node n)
        (eq? n first-node))
      (define (is-last-node n)
        (eq? n last-node))
      (for-each (lambda (node)
                  (unless (null? node)
                    (let* ((is-list (list? node))
                           (is-first (is-first-node node))
                           (is-last (is-last-node node))
                           (n (if is-list (car node) node))
                           (rest (if (and is-list (> (length node) 1)) (cdr node) '()))
                           (node-prefix (if is-last "`-- " "|-- "))
                           (tree-prefix (if is-last "    " "|   ")))
                      (display prefix)
                      (unless (and root is-first)
                        (display node-prefix))
                      (display n)
                      (newline)
                      (when (list? node)
                        (print-tree (cdr node)
                                    #:prefix (string-append prefix tree-prefix))))))
                tree))))

(define (print-directory-tree dir #:title (title ""))
  (unless (string-empty? title)
    (display title)
    (newline))
  (print-tree (walk-directory dir) #:root #t))