1#lang racket/base 2 3(require (for-syntax racket/base racket/require-transform racket/list syntax/stx 4 (only-in racket/syntax syntax-local-eval)) 5 "require-syntax.rkt") 6 7(provide matching-identifiers-in) 8(define-syntax matching-identifiers-in 9 (make-require-transformer 10 (lambda (stx) 11 (syntax-case stx () 12 [(_ rx spec) 13 (regexp? (syntax-e #'rx)) 14 (let ([rx (syntax-e #'rx)]) 15 (define-values [imports sources] (expand-import #'spec)) 16 (values 17 (filter (lambda (i) 18 (regexp-match? rx (symbol->string 19 (syntax-e (import-local-id i))))) 20 imports) 21 sources))])))) 22 23(provide subtract-in) 24(define-syntax subtract-in 25 (make-require-transformer 26 (lambda (stx) 27 (syntax-case stx () 28 [(_ spec specs ...) 29 (let* ([subs (map (lambda (spec) 30 (let-values ([(imports srcs) (expand-import spec)]) 31 imports)) 32 (syntax->list #'(specs ...)))] 33 [subs (map (lambda (i) (syntax-e (import-local-id i))) 34 (apply append subs))]) 35 (define-values [imports sources] (expand-import #'spec)) 36 (values (filter (lambda (i) 37 (not (memq (syntax-e (import-local-id i)) subs))) 38 imports) 39 sources))])))) 40 41(provide filtered-in) 42(define-syntax filtered-in 43 (make-require-transformer 44 (lambda (stx) 45 (syntax-case stx () 46 [(_ proc spec) 47 (let ([proc (syntax-local-eval #'proc)]) 48 (define-values [imports sources] (expand-import #'spec)) 49 (values 50 (filter-map 51 (lambda (i) 52 (let* ([id (import-local-id i)] 53 [s1 (symbol->string (syntax-e id))] 54 [s2 (proc s1)]) 55 (cond [(equal? s1 s2) i] 56 [(string? s2) (make-import (datum->syntax 57 id (string->symbol s2) id) 58 (import-src-sym i) 59 (import-src-mod-path i) 60 (import-mode i) 61 (import-req-mode i) 62 (import-orig-mode i) 63 (import-orig-stx i))] 64 [(not s2) #f] 65 [else (error 'filtered-in "bad result: ~e" s2)]))) 66 imports) 67 sources))])))) 68 69(provide path-up) 70(define-require-syntax (path-up stx) 71 (syntax-case stx () 72 [(_ path-stx ...) 73 (for/and ([ps (in-list (syntax->list #'(path-stx ...)))]) 74 (let ([s (syntax-e ps)]) (and (string? s) (module-path? s)))) 75 (let* ([src (syntax-source stx)] 76 [dirname (lambda (path) 77 (let-values ([(dir name dir?) (split-path path)]) dir))] 78 [srcdir (if (and (path-string? src) (complete-path? src)) 79 (dirname src) 80 (or (current-load-relative-directory) 81 (current-directory)))]) 82 (with-syntax 83 ([(paths ...) 84 (for/list ([ps (in-list (syntax->list #'(path-stx ...)))]) 85 (define path (syntax-e ps)) 86 (unless (complete-path? srcdir) (error 'path-up "internal error")) 87 (parameterize ([current-directory srcdir]) 88 (let loop ([dir srcdir] [path (string->path path)] [pathstr path]) 89 (if (file-exists? path) 90 (datum->syntax stx pathstr stx stx) 91 (let ([dir (dirname dir)]) 92 (if dir 93 (loop dir (build-path 'up path) 94 (string-append "../" pathstr)) 95 (raise-syntax-error 'path-up 96 "file not found in any parent directory" 97 stx ps)))))))]) 98 (syntax/loc stx (combine-in paths ...))))])) 99 100 101(define-for-syntax (multi xs) 102 (define (loop xs) 103 (if (stx-null? xs) 104 '(()) 105 (let ([first (stx-car xs)] 106 [rest (loop (stx-cdr xs))]) 107 (if (stx-list? first) 108 (let ([bads (filter stx-list? (syntax->list first))]) 109 (if (null? bads) 110 (append-map (λ (x) (map (λ (y) (cons x y)) rest)) (syntax->list first)) 111 (error 'multi-in "not a simple element" (car (syntax->datum bads))))) 112 (map (λ (x) (cons first x)) rest))))) 113 (define options (loop xs)) 114 (define (try pred? ->str str->) 115 (and (andmap (λ (x) (andmap pred? (map syntax-e x))) options) 116 (map (λ (x) 117 (let* ([d (map syntax-e x)] 118 [r (apply string-append 119 (add-between (if ->str (map ->str d) d) 120 "/"))] 121 [ctxt (last x)]) 122 (datum->syntax ctxt (if str-> (str-> r) r) ctxt ctxt))) 123 options))) 124 (or (try string? #f #f) 125 (try symbol? symbol->string string->symbol) 126 (error 'multi-in "only accepts all strings or all symbols"))) 127 128(provide multi-in) 129(define-require-syntax (multi-in stx) 130 (syntax-case stx () 131 [(_ elem0 elem ...) 132 (quasisyntax/loc stx 133 (combine-in #,@(multi #'(elem0 elem ...))))])) 134 135(module+ for-testing 136 (provide (for-syntax multi))) 137