|
4 | 4 | ;; - fix datum-literals ? |
5 | 5 | ;; - enable type-annotation test by upgrading user's annotations to trust codomain |
6 | 6 |
|
7 | | -(require |
8 | | - "../test-utils.rkt" |
9 | | - rackunit |
10 | | - racket/pretty |
11 | | - racket/list |
12 | | - racket/set |
13 | | - syntax/parse |
14 | | - (only-in racket/format ~a) |
15 | | - (only-in syntax/modread with-module-reading-parameterization)) |
| 7 | +(require racket/list |
| 8 | + racket/pretty |
| 9 | + racket/set |
| 10 | + rackunit |
| 11 | + syntax/parse |
| 12 | + (only-in racket/format ~a) |
| 13 | + (only-in syntax/modread with-module-reading-parameterization) |
| 14 | + "../test-utils.rkt") |
16 | 15 |
|
17 | 16 | (provide tests) |
18 | 17 | (gen-test-main) |
|
29 | 28 | (with-module-reading-parameterization |
30 | 29 | (lambda () |
31 | 30 | (read-syntax (object-name in-port) in-port)))))) |
32 | | - (define stx |
33 | | - (parameterize ((current-namespace (make-base-namespace))) |
34 | | - (expand mod-stx))) |
35 | | - stx) |
| 31 | + (parameterize ([current-namespace (make-base-namespace)]) |
| 32 | + (expand mod-stx))) |
36 | 33 |
|
37 | 34 | ;; --- |
38 | 35 |
|
|
49 | 46 |
|
50 | 47 | (define (stx-find orig-stx p?) |
51 | 48 | (define stx* (stx-find* orig-stx p?)) |
52 | | - (if (or (null? stx*) |
53 | | - (not (null? (cdr stx*)))) |
54 | | - (raise-arguments-error 'stx-find "non-unique results" "num matches" (length stx*) "orig-stx" orig-stx "predicate" p? "matches" stx*) |
55 | | - (car stx*))) |
| 49 | + (when (or (null? stx*) (not (null? (cdr stx*)))) |
| 50 | + (raise-arguments-error 'stx-find |
| 51 | + "non-unique results" |
| 52 | + "num matches" |
| 53 | + (length stx*) |
| 54 | + "orig-stx" |
| 55 | + orig-stx |
| 56 | + "predicate" |
| 57 | + p? |
| 58 | + "matches" |
| 59 | + stx*)) |
| 60 | + (car stx*)) |
56 | 61 |
|
57 | 62 | (define (stx-find* orig-stx p?) |
58 | 63 | (let loop ((stx orig-stx)) |
59 | 64 | (cond |
60 | 65 | [(syntax? stx) |
61 | | - (let ((v (p? stx))) |
62 | | - (if v |
63 | | - (list |
64 | | - (if (eq? #true v) stx v)) |
65 | | - (loop (syntax-e stx))))] |
| 66 | + (define v (p? stx)) |
| 67 | + (if v (list (if (eq? #true v) stx v)) (loop (syntax-e stx)))] |
66 | 68 | [(pair? stx) |
67 | 69 | (append (loop (car stx)) (loop (cdr stx)))] |
68 | 70 | [else |
|
79 | 81 | ((~literal #%plain-app) (~datum shallow-shape-check) . _))) |
80 | 82 |
|
81 | 83 | (define (stx-find-define-predicate-ctc stx pred-name) |
82 | | - (let* ((lift-id |
83 | | - (stx-find stx |
84 | | - (syntax-parser |
85 | | - #:datum-literals (define-values let-values #%app) |
86 | | - ((define-values (name:id) (let-values (((:id) (#%app fcp:id lift:id))) _)) |
87 | | - #:when (eq? (syntax-e #'name) pred-name) |
88 | | - #'lift) |
89 | | - (_ #f)) |
90 | | - )) |
91 | | - (lift-ctc |
92 | | - (stx-find stx |
93 | | - (syntax-parser |
94 | | - (((~datum define-values) (lt:id) ctc:id) |
95 | | - #:when (eq? (syntax-e #'lt) (syntax-e lift-id)) |
96 | | - #'ctc) |
97 | | - (_ #f)))) |
98 | | - (ctc* |
99 | | - (stx-find* stx |
100 | | - (syntax-parser |
101 | | - #:datum-literals (define-values lambda) |
102 | | - ((define-values (g:id) (lambda (_) body)) |
103 | | - #:when (eq? (syntax-e #'g) (syntax-e lift-ctc)) |
104 | | - #'body) |
105 | | - (_ #f))))) |
106 | | - (cond |
107 | | - [(null? ctc*) |
108 | | - lift-ctc] |
109 | | - [(null? (cdr ctc*)) |
110 | | - (car ctc*)] |
111 | | - [else |
112 | | - (raise-arguments-error 'stx-find-define-predicate-ctc "cannot find lifted" "pred" pred-name)]))) |
| 84 | + (define lift-id |
| 85 | + (stx-find stx |
| 86 | + (syntax-parser |
| 87 | + #:datum-literals (define-values let-values #%app) |
| 88 | + [(define-values (name:id) |
| 89 | + (let-values ([(:id) (#%app fcp:id lift:id)]) |
| 90 | + _)) |
| 91 | + #:when (eq? (syntax-e #'name) pred-name) |
| 92 | + #'lift] |
| 93 | + [_ #f]))) |
| 94 | + (define lift-ctc |
| 95 | + (stx-find stx |
| 96 | + (syntax-parser |
| 97 | + [((~datum define-values) (lt:id) ctc:id) |
| 98 | + #:when (eq? (syntax-e #'lt) (syntax-e lift-id)) |
| 99 | + #'ctc] |
| 100 | + [_ #f]))) |
| 101 | + (define ctc* |
| 102 | + (stx-find* stx |
| 103 | + (syntax-parser |
| 104 | + #:datum-literals (define-values lambda) |
| 105 | + [(define-values (g:id) (lambda (_) body)) |
| 106 | + #:when (eq? (syntax-e #'g) (syntax-e lift-ctc)) |
| 107 | + #'body] |
| 108 | + [_ #f]))) |
| 109 | + (cond |
| 110 | + [(null? ctc*) lift-ctc] |
| 111 | + [(null? (cdr ctc*)) (car ctc*)] |
| 112 | + [else |
| 113 | + (raise-arguments-error 'stx-find-define-predicate-ctc "cannot find lifted" "pred" pred-name)])) |
113 | 114 |
|
114 | 115 | (define (split-shape-check stx) |
115 | 116 | (define expr (->datum stx)) |
|
![resyntax-ci[bot]](https://avatars.githubusercontent.com/in/999945?v=4&size=40){kind=avatar}
0 commit comments