(module test mzscheme (require (lib "etc.ss")) (require (lib "file.ss")) (define remove-first (opt-lambda (x ls [equiv? eq?]) (let loop ([ls ls] [result '()]) (cond [(null? ls) #f] [(equiv? (car ls) x) (append (reverse result) (cdr ls))] [else (loop (cdr ls) (cons (car ls) result))])))) (define list-permutation? (opt-lambda (ls1 ls2 [equiv? eq?]) (let loop ([ls1 ls1] [ls2 ls2]) (cond [(and (null? ls1) (null? ls2)) #t] [(or (null? ls1) (null? ls2)) #f] [(remove-first (car ls1) ls2 equiv?) => (lambda (ls2*) (loop (cdr ls1) ls2*))] [else #f])))) (define-syntax (source-directory-of-expression stx) (syntax-case stx () [(_ context) (syntax/loc #'context (this-expression-source-directory))])) (define-syntax (in-this-directory stx) (syntax-case stx () [(_ e1 e2 ...) #`(parameterize ([current-directory (source-directory-of-expression #,stx)]) e1 e2 ...)])) (define (rm-rf path) (when (or (file-exists? path) (directory-exists? path)) (delete-directory/files path))) (define keep-new-directories? (make-parameter #f (lambda (new-b) (if (not (boolean? new-b)) (raise-type-error 'keep-new-directories? "boolean" new-b) new-b)))) (define-syntax in-new-directory (syntax-rules () [(_ dir-e e1 e2 ...) (let ([dir dir-e]) (dynamic-wind void (lambda () (when (directory-exists? dir) (error 'in-new-directory "can't create directory ~a; directory exists" dir)) (make-directory* dir) (parameterize ([current-directory dir] [keep-new-directories? #t]) e1 e2 ...)) (lambda () (unless (keep-new-directories?) (rm-rf dir)))))])) (provide list-permutation? keep-new-directories? in-new-directory source-directory-of-expression in-this-directory))