|
4 | 4 | rackunit |
5 | 5 | racket/list |
6 | 6 | (for-syntax racket/base syntax/parse) |
| 7 | + syntax/location syntax/srcloc |
7 | 8 | (rep type-rep) |
8 | 9 | (r:infer infer) |
9 | 10 |
|
|
21 | 22 |
|
22 | 23 | (begin-for-syntax |
23 | 24 | (define-splicing-syntax-class result |
24 | | - (pattern (~seq) #:with v #'#f) |
25 | | - (pattern (~seq #:result v:expr))) |
| 25 | + (pattern (~seq) #:with v #'#f #:with exp #'#f) |
| 26 | + (pattern (~seq #:result [v:expr exp:expr]))) |
26 | 27 | (define-splicing-syntax-class vars |
27 | 28 | (pattern (~seq) #:with vars #'empty) |
28 | 29 | (pattern (~seq #:vars vars:expr))) |
|
36 | 37 |
|
37 | 38 | (define-syntax (infer-t stx) |
38 | 39 | (syntax-parse stx |
39 | | - ([_ S:expr T:expr R:result :vars :indices :pass] |
| 40 | + ([_ S:expr T:expr . rest] |
40 | 41 | (syntax/loc stx |
41 | | - (test-case (format "~a ~a~a" S T (if pass "" " should fail")) |
42 | | - (define result (infer vars indices (list S) (list T) R.v)) |
43 | | - (unless (if pass result (not result)) |
44 | | - (fail-check "Could not infer a substitution"))))))) |
| 42 | + (infer-l (list S) (list T) . rest))))) |
45 | 43 |
|
46 | 44 | (define-syntax (infer-l stx) |
47 | 45 | (syntax-parse stx |
48 | | - ([_ S:expr T:expr R:result :vars :indices :pass] |
49 | | - (syntax/loc stx |
| 46 | + ([_ S:expr T:expr :vars :indices R:result :pass] |
| 47 | + (quasisyntax/loc stx |
50 | 48 | (test-case (format "~a ~a~a" S T (if pass "" " should fail")) |
51 | | - (define result (infer vars indices S T R.v)) |
52 | | - (unless (if pass result (not result)) |
53 | | - (fail-check "Could not infer a substitution"))))))) |
| 49 | + (with-check-info (['location (build-source-location-list (quote-srcloc #,stx))]) |
| 50 | + (define substitution (infer vars indices S T R.v)) |
| 51 | + (define result (and substitution R.v (subst-all substitution R.v))) |
| 52 | + (cond |
| 53 | + [pass |
| 54 | + (unless substitution |
| 55 | + (fail-check "Could not infer a substitution")) |
| 56 | + (when result |
| 57 | + (with-check-info (['actual result] ['expected R.exp]) |
| 58 | + (unless (equal? result R.exp) |
| 59 | + (fail-check "Did not infer the expected result."))))] |
| 60 | + [fail |
| 61 | + (when substitution |
| 62 | + (fail-check "Inferred an unexpected substitution."))]))))))) |
54 | 63 |
|
55 | 64 |
|
56 | 65 | (define-syntax-rule (i2-t t1 t2 (a b) ...) |
|
90 | 99 | (test-suite "Tests for infer" |
91 | 100 | (infer-t Univ Univ) |
92 | 101 | (infer-t (-v a) Univ) |
93 | | - (infer-t (-v a) (-v a) #:result (-v a)) |
| 102 | + (infer-t (-v a) (-v a) #:result [(-v a) (-v a)]) |
94 | 103 | (infer-t Univ (-v a) #:fail) |
95 | 104 | (infer-t Univ (-v a) #:vars '(a)) |
96 | 105 | (infer-t (-v a) Univ #:vars '(a)) |
|
112 | 121 | (infer-t (make-ListDots (-v b) 'b) (make-ListDots Univ 'b) #:indices '(b)) |
113 | 122 | (infer-t (-pair (-v a) (make-ListDots (-v b) 'b)) |
114 | 123 | (-pair (-v a) (make-ListDots (-v b) 'b)) |
115 | | - #:result (-v a)) |
| 124 | + #:result [(-v a) (-v a)]) |
116 | 125 |
|
117 | 126 | [infer-t (->... null ((-v a) a) (-v b)) (-> -Symbol -String) #:vars '(b) #:indices '(a)] |
118 | 127 | [infer-t (->... null ((-v a) a) (make-ListDots (-v a) 'a)) (-> -String -Symbol (-lst* -String -Symbol)) #:indices '(a)] |
|
142 | 151 | [i2-t ((-v a) . -> . (-v b)) (-> N N) ('b N) ('a (Un))] |
143 | 152 |
|
144 | 153 |
|
145 | | - [i2-l (list (-v a) (-v a) (-v b)) |
| 154 | + [i2-l (list (-v a) (-v a) (-v b)) |
146 | 155 | (list (Un (-val 1) (-val 2)) N N) |
147 | 156 | '(a b) ('b N) ('a N)] |
148 | 157 | [i2-l (list (-> (-v a) Univ) (-lst (-v a))) |
|
0 commit comments