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