|
25 | 25 | #:property prop:combinator-name "dep->/sc" |
26 | 26 | #:methods gen:sc |
27 | 27 | [(define (sc->contract v rec) |
28 | | - (match v |
29 | | - [(->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) |
30 | | - (with-syntax ([(id ...) ids] |
31 | | - [(c ...) (for/list ([d/sc (in-list dom/scs)] |
32 | | - [dep-ids (in-list dom-deps)]) |
33 | | - (cond |
34 | | - [(not (null? dep-ids)) |
35 | | - (parameterize ([static-contract-may-contain-free-ids? #t]) |
36 | | - (rec d/sc))] |
37 | | - [else (rec d/sc)]))] |
38 | | - [(dep ...) dom-deps] |
39 | | - [(r-deps ...) rng-deps] |
40 | | - [(p-deps ...) pre-deps]) |
41 | | - #`(->i ([id dep c] ...) |
42 | | - #,@(cond |
43 | | - [(not pre) #'()] |
44 | | - [else #`(#:pre (p-deps ...) |
45 | | - #,(cond |
46 | | - [(not (null? pre-deps)) |
47 | | - (parameterize ([static-contract-may-contain-free-ids? #t]) |
48 | | - (rec pre))] |
49 | | - [else (rec pre)]))]) |
50 | | - #,(cond |
51 | | - [(and typed-side? (andmap any/sc? rng-deps)) #'any] |
52 | | - [(null? rng-deps) |
53 | | - #`[_ () (values #,@(map rec rng/scs))]] |
54 | | - [else |
55 | | - (parameterize ([static-contract-may-contain-free-ids? #t]) |
56 | | - #`[_ (r-deps ...) (values #,@(map rec rng/scs))])])))])) |
| 28 | + (match-define (->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) v) |
| 29 | + (with-syntax ([(id ...) ids] |
| 30 | + [(c ...) (for/list ([d/sc (in-list dom/scs)] |
| 31 | + [dep-ids (in-list dom-deps)]) |
| 32 | + (cond |
| 33 | + [(not (null? dep-ids)) |
| 34 | + (parameterize ([static-contract-may-contain-free-ids? #t]) |
| 35 | + (rec d/sc))] |
| 36 | + [else (rec d/sc)]))] |
| 37 | + [(dep ...) dom-deps] |
| 38 | + [(r-deps ...) rng-deps] |
| 39 | + [(p-deps ...) pre-deps]) |
| 40 | + #`(->i ([id dep c] ...) |
| 41 | + #,@(cond |
| 42 | + [(not pre) #'()] |
| 43 | + [else |
| 44 | + #`(#:pre (p-deps ...) |
| 45 | + #,(cond |
| 46 | + [(not (null? pre-deps)) |
| 47 | + (parameterize ([static-contract-may-contain-free-ids? #t]) |
| 48 | + (rec pre))] |
| 49 | + [else (rec pre)]))]) |
| 50 | + #,(cond |
| 51 | + [(and typed-side? (andmap any/sc? rng-deps)) #'any] |
| 52 | + [(null? rng-deps) #`[_ () (values #,@(map rec rng/scs))]] |
| 53 | + [else |
| 54 | + (parameterize ([static-contract-may-contain-free-ids? #t]) |
| 55 | + #`[_ (r-deps ...) (values #,@(map rec rng/scs))])])))) |
57 | 56 | (define (sc-map v f) |
58 | | - (match v |
59 | | - [(->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) |
60 | | - (->i/sc typed-side? |
61 | | - ids |
62 | | - (for/list ([d/sc (in-list dom/scs)]) |
63 | | - (f d/sc 'contravariant)) |
64 | | - dom-deps |
65 | | - (and pre (f pre 'contravariant)) |
66 | | - pre-deps |
67 | | - (for/list ([r/sc (in-list rng/scs)]) |
68 | | - (f r/sc 'covariant)) |
69 | | - rng-deps)])) |
| 57 | + (match-define (->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) v) |
| 58 | + (->i/sc typed-side? |
| 59 | + ids |
| 60 | + (for/list ([d/sc (in-list dom/scs)]) |
| 61 | + (f d/sc 'contravariant)) |
| 62 | + dom-deps |
| 63 | + (and pre (f pre 'contravariant)) |
| 64 | + pre-deps |
| 65 | + (for/list ([r/sc (in-list rng/scs)]) |
| 66 | + (f r/sc 'covariant)) |
| 67 | + rng-deps)) |
70 | 68 | (define (sc-traverse v f) |
71 | | - (match v |
72 | | - [(->i/sc _ _ dom/scs _ pre _ rng/scs _) |
73 | | - (for ([d/sc (in-list dom/scs)]) |
74 | | - (f d/sc 'contravariant)) |
75 | | - (when pre (f pre 'contravariant)) |
76 | | - (for ([r/sc (in-list rng/scs)]) |
77 | | - (f r/sc 'covariant))])) |
| 69 | + (match-define (->i/sc _ _ dom/scs _ pre _ rng/scs _) v) |
| 70 | + (for ([d/sc (in-list dom/scs)]) |
| 71 | + (f d/sc 'contravariant)) |
| 72 | + (when pre |
| 73 | + (f pre 'contravariant)) |
| 74 | + (for ([r/sc (in-list rng/scs)]) |
| 75 | + (f r/sc 'covariant))) |
78 | 76 | (define (sc-terminal-kind v) 'impersonator) |
79 | 77 | (define (sc->constraints v f) |
80 | | - (match v |
81 | | - [(->i/sc _ _ dom/scs _ pre _ rng/scs _) |
82 | | - (merge-restricts* 'impersonator |
83 | | - (append (if pre (list (f pre)) (list)) |
84 | | - (map f rng/scs) |
85 | | - (map f dom/scs)))]))]) |
| 78 | + (match-define (->i/sc _ _ dom/scs _ pre _ rng/scs _) v) |
| 79 | + (merge-restricts* 'impersonator |
| 80 | + (append (if pre |
| 81 | + (list (f pre)) |
| 82 | + (list)) |
| 83 | + (map f rng/scs) |
| 84 | + (map f dom/scs))))]) |
86 | 85 |
|
87 | 86 | (require-for-cond-contract "proposition.rkt") |
88 | 87 |
|
|
0 commit comments