suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Moved FS code into plt-tree.ss

Browse Source 
svn: r17529
This commit is contained in:
Eli Barzilay 2010-01-07 10:28:11 +00:00
parent ecb1f6525d
commit daa1c0b338
3 changed files with 41 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/meta/tree/plt-tree.ss
View File

@ -1,7 +1,35 @@
#lang scheme/base
(provide get-tree get-plt-tree)
(require "tree.ss" setup/dirs)
;; ----------------------------------------------------------------------------
;; Reading a tree from a directory
(define (get-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-tree "bad path encountered: ~a/~a"
(current-directory) path)])))
;; ----------------------------------------------------------------------------
;; Reading the PLT tree
(define (get-plt-tree)
(when absolute-installation?
(error 'get-plt-tree "must be used from a relative installation"))

19
collects/meta/tree/tests.ss
View File

@ -2,13 +2,13 @@
(require tests/eli-tester scheme/sandbox scheme/runtime-path scheme/file)
(define-runtime-path tree "tree.ss")
(define e
(call-with-trusted-sandbox-configuration
(lambda () (make-module-evaluator tree))))
(define-runtime-path tree-module "tree.ss")
(define-runtime-path plt-tree-module "plt-tree.ss")
(define (glob-tests)
(define e
(call-with-trusted-sandbox-configuration
(lambda () (make-module-evaluator tree-module))))
(define (g->rl x)
(let ([r (e `(glob->regexp-or-literal ,x))])
(if (byte-regexp? r) `(rx ,(object-name r)) r)))
@ -42,9 +42,13 @@
(g->rl #"gl[]*]ob") => '(rx #"^gl[]*]ob$")
(g->rl #"gl[^]*]ob") => '(rx #"^gl[^]*]ob$")
(g->rl #"gl[^]*]*ob") => '(rx #"^gl[^]*].*ob$")
))
)
(kill-evaluator e))
(define (tree-tests)
(define e
(call-with-trusted-sandbox-configuration
(lambda () (make-module-evaluator plt-tree-module))))
(define a-dir (collection-path "scribble"))
(define a-list (find-files void a-dir))
(define a-tree #f)
@ -3904,7 +3908,8 @@
=> same-as-last-datums
;; no .svn or compiled directories using `and:'
(e/filter '(and: (not: "**/.svn/") (not: "**/compiled/")))
=> same-as-last-datums))
=> same-as-last-datums)
(kill-evaluator e))
(test do (glob-tests)
do (tree-tests))

25
collects/meta/tree/tree.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(provide (struct-out tree) leaf? tree-foldl tree-foldr tree-for-each tree->list
and: or: not: tree-filter get-tree)
and: or: not: tree-filter)
(require scheme/list)
@ -235,26 +235,3 @@
(error 'tree-filter "expecting a non-leaf, got ~e" tree)
(or (subs-filter pred tree)
(make-tree (tree-name tree) '() (tree-path tree)))))
;; ----------------------------------------------------------------------------
;; Reading a tree from a directory
(define (get-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-tree "bad path encountered: ~a/~a"
(current-directory) path)])))