|
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