59 lines
1.8 KiB
Racket
59 lines
1.8 KiB
Racket
(module foldo mzscheme
|
|
(require (lib "file.rkt") (lib "match.rkt"))
|
|
(provide apply-to-scheme-files)
|
|
|
|
(define-syntax (define-excluder stx)
|
|
|
|
(define (path->clause c)
|
|
(syntax-case c ()
|
|
[(item ...)
|
|
#`[`(#,@(reverse (syntax-e #'(item ...))) ,_ (... ...)) #t]]
|
|
[item
|
|
#`[`(item) #t]]))
|
|
|
|
(syntax-case stx ()
|
|
[(_ name path ...)
|
|
(with-syntax ([(match-clause ...) (map path->clause (syntax-e #'(path ...)))])
|
|
#`(define (name p )
|
|
(let* ([dirnames (map path->string (explode-path p))])
|
|
(match (reverse dirnames) ; goofy backwards matching because ... matches greedily
|
|
match-clause ...
|
|
[_ #f]))))]))
|
|
|
|
(define-excluder default-excluder
|
|
"compiled" ".git")
|
|
|
|
(define exclude-directory? (make-parameter default-excluder))
|
|
|
|
;; ----------------------------------------
|
|
;; apply-to-scheme-files: (path[file] -> X) path[directory] -> (listof X)
|
|
;; applies the given function to each .rkt or .ss or .scm file in the given
|
|
;; directory hierarchy; returns all results in a list
|
|
(define (apply-to-scheme-files f root )
|
|
;;FOLD-FILES
|
|
|
|
(fold-files
|
|
(lambda (path kind acc)
|
|
(case kind
|
|
[(file)
|
|
(let ([extension (filename-extension path)])
|
|
(cond
|
|
[(not extension) acc ]
|
|
[(regexp-match #rx"(rkt|rktl|ss|scm)$" extension)
|
|
(let ([resl (f path)])
|
|
(if resl
|
|
(cons resl acc)
|
|
acc ))]
|
|
[else acc ]))]
|
|
[(dir)
|
|
(let* ([p (normalize-path path root)])
|
|
(if ((exclude-directory?) p)
|
|
(values acc #f)
|
|
acc ))]
|
|
[(link) acc ]
|
|
[else (error "never happen")]))
|
|
'()
|
|
root
|
|
))
|
|
)
|