|
132 | 132 | (define name-ref->sexp |
133 | 133 | (match-lambda |
134 | 134 | [(? syntax? name-ref) (syntax-e name-ref)] |
135 | | - [(cons lvl arg) `(,lvl ,arg)])) |
| 135 | + [(cons lvl arg) (list lvl arg)])) |
136 | 136 |
|
137 | 137 | ;; prop->sexp : Prop -> S-expression |
138 | 138 | ;; Print a Prop (see prop-rep.rkt) to the given port |
|
149 | 149 | ;; instead of (<= x y) (<= y x) when we have both inequalities |
150 | 150 | (define-values (leqs others) (partition LeqProp? ps)) |
151 | 151 | (define-values (eqs simple-leqs) |
152 | | - (for/fold ([eqs '()] [simple-leqs '()]) |
| 152 | + (for/fold ([eqs '()] |
| 153 | + [simple-leqs '()]) |
153 | 154 | ([leq (in-list leqs)]) |
154 | | - (match leq |
155 | | - [(LeqProp: lhs rhs) |
156 | | - (define flip (-leq rhs lhs)) |
157 | | - (cond |
158 | | - [(not (member flip leqs)) |
159 | | - (values eqs (cons leq simple-leqs))] |
160 | | - [(member flip eqs) (values eqs simple-leqs)] |
161 | | - [else (values (cons leq eqs) simple-leqs)])]))) |
| 155 | + (match-define (LeqProp: lhs rhs) leq) |
| 156 | + (define flip (-leq rhs lhs)) |
| 157 | + (cond |
| 158 | + [(not (member flip leqs)) (values eqs (cons leq simple-leqs))] |
| 159 | + [(member flip eqs) (values eqs simple-leqs)] |
| 160 | + [else (values (cons leq eqs) simple-leqs)]))) |
162 | 161 | (let ([simple-leqs (map prop->sexp simple-leqs)] |
163 | 162 | [eqs (for/list ([leq (in-list eqs)]) |
164 | | - (match leq |
165 | | - [(LeqProp: lhs rhs) `(= ,(object->sexp lhs) ,(object->sexp rhs))]))] |
| 163 | + (match-define (LeqProp: lhs rhs) leq) |
| 164 | + `(= ,(object->sexp lhs) ,(object->sexp rhs)))] |
166 | 165 | [others (map prop->sexp others)]) |
167 | 166 | (match (append eqs simple-leqs others) |
168 | 167 | [(list sexp) sexp] |
|
317 | 316 | valid-names)) |
318 | 317 | ;; some types in the union may not be coverable by the candidates |
319 | 318 | ;; (e.g. type variables, etc.) |
320 | | - (define-values (uncoverable coverable) |
321 | | - (values (apply set-subtract elems (map cdr candidates)) |
322 | | - (set-intersect elems (apply set-union null (map cdr candidates))))) |
| 319 | + (define uncoverable (apply set-subtract elems (map cdr candidates))) |
| 320 | + (define coverable (set-intersect elems (apply set-union null (map cdr candidates)))) |
323 | 321 | ;; set cover, greedy algorithm, ~lg n approximation |
324 | 322 | (let loop ([to-cover coverable] |
325 | 323 | [candidates candidates] |
326 | 324 | [coverage '()]) |
327 | | - (cond [(null? to-cover) ; done |
328 | | - (define coverage-names (map car coverage)) |
329 | | - ;; to allow :type to cue the user on unexpanded aliases |
330 | | - ;; only union types can flow here, and any of those could be expanded |
331 | | - (set-box! (current-print-unexpanded) |
332 | | - (append coverage-names (unbox (current-print-unexpanded)))) |
333 | | - ;; reverse here to retain the old ordering from when srfi/1 was |
334 | | - ;; used to process the list sets |
335 | | - (values coverage-names (reverse uncoverable))] ; we want the names |
336 | | - [else |
337 | | - ;; pick the candidate that covers the most uncovered types |
338 | | - (define (covers-how-many? c) |
339 | | - (length (set-intersect (cdr c) to-cover))) |
340 | | - (define-values (next _) |
341 | | - (for/fold ([next (car candidates)] |
342 | | - [max-cover (covers-how-many? (car candidates))]) |
343 | | - ([c (in-list candidates)]) |
344 | | - (let ([how-many? (covers-how-many? c)]) |
345 | | - (if (> how-many? max-cover) |
346 | | - (values c how-many?) |
347 | | - (values next max-cover))))) |
348 | | - (loop (set-subtract to-cover (cdr next)) |
349 | | - (remove next candidates) |
350 | | - (cons next coverage))]))) |
| 325 | + (cond |
| 326 | + [(null? to-cover) ; done |
| 327 | + (define coverage-names (map car coverage)) |
| 328 | + ;; to allow :type to cue the user on unexpanded aliases |
| 329 | + ;; only union types can flow here, and any of those could be expanded |
| 330 | + (set-box! (current-print-unexpanded) |
| 331 | + (append coverage-names (unbox (current-print-unexpanded)))) |
| 332 | + ;; reverse here to retain the old ordering from when srfi/1 was |
| 333 | + ;; used to process the list sets |
| 334 | + (values coverage-names (reverse uncoverable))] ; we want the names |
| 335 | + [else |
| 336 | + ;; pick the candidate that covers the most uncovered types |
| 337 | + (define (covers-how-many? c) |
| 338 | + (length (set-intersect (cdr c) to-cover))) |
| 339 | + (define next |
| 340 | + (for/fold ([next (car candidates)] |
| 341 | + [max-cover (covers-how-many? (car candidates))] |
| 342 | + #:result next) |
| 343 | + ([c (in-list candidates)]) |
| 344 | + (let ([how-many? (covers-how-many? c)]) |
| 345 | + (if (> how-many? max-cover) |
| 346 | + (values c how-many?) |
| 347 | + (values next max-cover))))) |
| 348 | + (loop (set-subtract to-cover (cdr next)) (remove next candidates) (cons next coverage))]))) |
351 | 349 |
|
352 | 350 | ;; arr->sexp : arr -> s-expression |
353 | 351 | ;; Convert an arr (see type-rep.rkt) to its printable form |
|
365 | 363 | ;; as long as the resulting s-expressions are `display`ed |
366 | 364 | ;; this is fine, though it may not pretty-print well. |
367 | 365 | (for/list ([kw (in-list kws)]) |
368 | | - (match kw |
369 | | - [(Keyword: k t req?) |
370 | | - (if req? |
371 | | - (format "~a ~a" k (type->sexp t)) |
372 | | - (format "[~a ~a]" k (type->sexp t)))])) |
| 366 | + (match-define (Keyword: k t req?) kw) |
| 367 | + (if req? |
| 368 | + (format "~a ~a" k (type->sexp t)) |
| 369 | + (format "[~a ~a]" k (type->sexp t)))) |
373 | 370 | (match rst |
374 | 371 | [(Rest: (list rst-t)) `(,(type->sexp rst-t) *)] |
375 | 372 | [(Rest: rst-ts) `(#:rest-star ,(map type->sexp rst-ts))] |
|
461 | 458 | (define-values (pre mid) (split-at lst to-drop)) |
462 | 459 | (define-values (sub post) (split-at mid n)) |
463 | 460 | (list pre sub post))) |
464 | | - (apply append (for/list ([i (range (length lst) 0 -1)]) |
465 | | - (sublist-n i lst)))) |
| 461 | + (for*/list ([i (range (length lst) 0 -1)] |
| 462 | + [v (in-list (sublist-n i lst))]) |
| 463 | + v)) |
466 | 464 | (let loop ([left-to-cover arrs]) |
467 | 465 | ;; try to match the largest sublists possible that correspond to |
468 | 466 | ;; ->* types and then the remainder are formatted normally |
|
478 | 476 | ;; case-lambda->sexp : Type -> S-expression |
479 | 477 | ;; Convert a case-> type to an s-expression |
480 | 478 | (define (case-lambda->sexp type) |
481 | | - (match type |
482 | | - [(Fun: arrows) |
483 | | - (match arrows |
484 | | - [(list) '(case->)] |
485 | | - [(list a) (arr->sexp a)] |
486 | | - [(and arrs (list a b ...)) |
487 | | - (define cover (cover-case-lambda arrs)) |
488 | | - (if (> (length cover) 1) |
489 | | - `(case-> ,@cover) |
490 | | - (car cover))])])) |
| 479 | + (match-define (Fun: arrows) type) |
| 480 | + (match arrows |
| 481 | + [(list) '(case->)] |
| 482 | + [(list a) (arr->sexp a)] |
| 483 | + [(and arrs (list a b ...)) |
| 484 | + (define cover (cover-case-lambda arrs)) |
| 485 | + (if (> (length cover) 1) |
| 486 | + `(case-> ,@cover) |
| 487 | + (car cover))])) |
491 | 488 |
|
492 | 489 | ;; class->sexp : Class [#:object? Boolean] -> S-expression |
493 | 490 | ;; Convert a class or object type to an s-expression |
|
512 | 509 | (cons 'field |
513 | 510 | (for/list ([name+type (in-list fields)]) |
514 | 511 | (match-define (list name type) name+type) |
515 | | - `(,name ,(type->sexp type))))))) |
| 512 | + (list name (type->sexp type))))))) |
516 | 513 | (define methods* |
517 | 514 | (for/list ([name+type (in-list methods)]) |
518 | 515 | (match-define (list name type) name+type) |
519 | | - `(,name ,(type->sexp type)))) |
| 516 | + (list name (type->sexp type)))) |
520 | 517 | (define augments* |
521 | 518 | (cond [(or object? (null? augments)) '()] |
522 | 519 | [else (list (cons 'augment augments))])) |
|
![resyntax-ci[bot]](https://avatars.githubusercontent.com/in/999945?v=4&size=40){kind=avatar}
0 commit comments