52 lines
1.7 KiB
Racket
52 lines
1.7 KiB
Racket
#lang scheme/base
|
|
|
|
(provide get-file-tree get-plt-file-tree)
|
|
|
|
(require "tree.ss" setup/dirs)
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Reading a tree from a directory
|
|
|
|
(define (get-file-tree path)
|
|
(define path* (simplify-path path))
|
|
(let loop ([path path*]
|
|
[name (regexp-replace #rx#"/$" (path->bytes path*) #"")])
|
|
(cond [(directory-exists? path)
|
|
(make-tree
|
|
(bytes-append name #"/")
|
|
(parameterize ([current-directory path])
|
|
(let* ([subs (map (lambda (sub)
|
|
(cons (path-element->bytes sub) sub))
|
|
(directory-list))]
|
|
[subs (sort subs bytes<? #:key car)])
|
|
(map (lambda (sub)
|
|
(loop (build-path path (cdr sub)) (car sub)))
|
|
subs)))
|
|
path)]
|
|
[(file-exists? path) (make-tree name #f path)]
|
|
[else (error 'get-file-tree "bad path encountered: ~a/~a"
|
|
(current-directory) path)])))
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Reading the PLT tree
|
|
|
|
(define (get-plt-file-tree)
|
|
(when absolute-installation?
|
|
(error 'get-plt-tree "must be used from a relative installation"))
|
|
(get-file-tree (build-path (find-collects-dir) 'up)))
|
|
|
|
#| good for benchmarking changes
|
|
(printf "getting tree ")
|
|
(define t (time (get-plt-file-tree)))
|
|
;;!!! (printf "adding deps ")
|
|
;;!!! (time (add-deps! t))
|
|
(printf "filtering x 1000 ")
|
|
(time
|
|
(for ([i (in-range 1000)])
|
|
(tree-filter
|
|
(not: (or: "**/.svn/" "**/compiled/"))
|
|
;; (get-file-tree "/home/scheme/plt/collects/scribble/.svn")
|
|
t
|
|
)))
|
|
|#
|