|
182 | 182 |
|
183 | 183 |
|
184 | 184 | (define (add-constraint cr max)
|
185 |
| - (match cr |
186 |
| - [(contract-restrict v rec constraints) |
187 |
| - (define con (constraint v max)) |
188 |
| - (if (trivial-constraint? con) |
189 |
| - cr |
190 |
| - (contract-restrict v rec (set-add constraints con)))])) |
| 185 | + (match-define (contract-restrict v rec constraints) cr) |
| 186 | + (define con (constraint v max)) |
| 187 | + (if (trivial-constraint? con) cr (contract-restrict v rec (set-add constraints con)))) |
191 | 188 |
|
192 |
| -(define (add-recursive-values cr dict) |
193 |
| - (match cr |
194 |
| - [(contract-restrict v rec constraints) |
195 |
| - (contract-restrict v (free-id-table-union (list rec dict)) constraints)])) |
| 189 | +(define (add-recursive-values cr dict) |
| 190 | + (match-define (contract-restrict v rec constraints) cr) |
| 191 | + (contract-restrict v (free-id-table-union (list rec dict)) constraints)) |
196 | 192 |
|
197 | 193 | (define (merge-restricts* min crs)
|
198 | 194 | (apply merge-restricts min crs))
|
199 | 195 |
|
200 | 196 | (define (merge-restricts min . crs)
|
201 |
| - (match crs |
202 |
| - [(list (contract-restrict vs rec constraints) ...) |
203 |
| - (contract-restrict (merge-kind-maxes min vs) |
204 |
| - (free-id-table-union rec) |
205 |
| - (apply set-union (set) constraints))])) |
| 197 | + (match-define (list (contract-restrict vs rec constraints) ...) crs) |
| 198 | + (contract-restrict (merge-kind-maxes min vs) |
| 199 | + (free-id-table-union rec) |
| 200 | + (apply set-union (set) constraints))) |
206 | 201 |
|
207 | 202 | (define (merge-kind-maxes min-kind vs)
|
208 |
| - (match vs |
209 |
| - [(list (kind-max variables maxes) ...) |
210 |
| - (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes))])) |
| 203 | + (match-define (list (kind-max variables maxes) ...) vs) |
| 204 | + (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes))) |
211 | 205 |
|
212 | 206 | (define (close-loop names crs body)
|
213 | 207 | (define eqs (make-equation-set))
|
|
225 | 219 | (match km
|
226 | 220 | [(kind-max ids actual)
|
227 | 221 | (define-values (bvals unbound-ids)
|
228 |
| - (for/fold ([bvals '()] [ubids (make-immutable-free-id-table)]) |
| 222 | + (for/fold ([bvals '()] |
| 223 | + [ubids (make-immutable-free-id-table)]) |
229 | 224 | ([(id _) (in-free-id-table ids)])
|
230 | 225 | (if (member id names)
|
231 | 226 | (values (cons (contract-restrict-value (lookup-id id)) bvals) ubids)
|
232 | 227 | (values bvals (free-id-table-set ubids id #t)))))
|
233 | 228 | (merge-kind-maxes 'flat (cons (kind-max unbound-ids actual) bvals))]))
|
234 |
| - |
| 229 | + |
235 | 230 | (define (instantiate-constraint con)
|
236 |
| - (match con |
237 |
| - [(constraint km bound) |
238 |
| - (constraint (instantiate-kind-max km) bound)])) |
239 |
| - |
240 |
| - (match cr |
241 |
| - [(contract-restrict (kind-max ids max) rec constraints) |
242 |
| - (define-values (bound-vals unbound-ids) |
243 |
| - (for/fold ([bvs '()] [ubids (make-immutable-free-id-table)]) |
244 |
| - ([(id _) (in-free-id-table ids)]) |
245 |
| - (if (member id names) |
246 |
| - (values (cons (lookup-id id) bvs) ubids) |
247 |
| - (values bvs (free-id-table-set ubids id #t))))) |
248 |
| - (merge-restricts* 'flat (cons |
249 |
| - (contract-restrict |
250 |
| - (kind-max unbound-ids max) |
251 |
| - rec |
252 |
| - (for*/set ([c (in-immutable-set constraints)] |
253 |
| - [ic (in-value (instantiate-constraint c))] |
254 |
| - #:when (not (trivial-constraint? ic))) |
255 |
| - ic)) |
256 |
| - bound-vals))])) |
| 231 | + (match-define (constraint km bound) con) |
| 232 | + (constraint (instantiate-kind-max km) bound)) |
| 233 | + (match-define (contract-restrict (kind-max ids max) rec constraints) cr) |
| 234 | + (define-values (bound-vals unbound-ids) |
| 235 | + (for/fold ([bvs '()] |
| 236 | + [ubids (make-immutable-free-id-table)]) |
| 237 | + ([(id _) (in-free-id-table ids)]) |
| 238 | + (if (member id names) |
| 239 | + (values (cons (lookup-id id) bvs) ubids) |
| 240 | + (values bvs (free-id-table-set ubids id #t))))) |
| 241 | + (merge-restricts* 'flat |
| 242 | + (cons (contract-restrict (kind-max unbound-ids max) |
| 243 | + rec |
| 244 | + (for*/set ([c (in-immutable-set constraints)] |
| 245 | + [ic (in-value (instantiate-constraint c))] |
| 246 | + #:when (not (trivial-constraint? ic))) |
| 247 | + ic)) |
| 248 | + bound-vals))) |
257 | 249 |
|
258 | 250 | (for ([name (in-list names)]
|
259 | 251 | [cr (in-list crs)])
|
|
0 commit comments