diff --git a/typed-racket-lib/typed-racket/static-contracts/constraints.rkt b/typed-racket-lib/typed-racket/static-contracts/constraints.rkt index 6a47157e9..fd4f02e84 100644 --- a/typed-racket-lib/typed-racket/static-contracts/constraints.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/constraints.rkt @@ -182,32 +182,26 @@ (define (add-constraint cr max) - (match cr - [(contract-restrict v rec constraints) - (define con (constraint v max)) - (if (trivial-constraint? con) - cr - (contract-restrict v rec (set-add constraints con)))])) + (match-define (contract-restrict v rec constraints) cr) + (define con (constraint v max)) + (if (trivial-constraint? con) cr (contract-restrict v rec (set-add constraints con)))) -(define (add-recursive-values cr dict) - (match cr - [(contract-restrict v rec constraints) - (contract-restrict v (free-id-table-union (list rec dict)) constraints)])) +(define (add-recursive-values cr dict) + (match-define (contract-restrict v rec constraints) cr) + (contract-restrict v (free-id-table-union (list rec dict)) constraints)) (define (merge-restricts* min crs) (apply merge-restricts min crs)) (define (merge-restricts min . crs) - (match crs - [(list (contract-restrict vs rec constraints) ...) - (contract-restrict (merge-kind-maxes min vs) - (free-id-table-union rec) - (apply set-union (set) constraints))])) + (match-define (list (contract-restrict vs rec constraints) ...) crs) + (contract-restrict (merge-kind-maxes min vs) + (free-id-table-union rec) + (apply set-union (set) constraints))) (define (merge-kind-maxes min-kind vs) - (match vs - [(list (kind-max variables maxes) ...) - (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes))])) + (match-define (list (kind-max variables maxes) ...) vs) + (kind-max (free-id-set-union variables) (apply combine-kinds min-kind maxes))) (define (close-loop names crs body) (define eqs (make-equation-set)) @@ -225,35 +219,33 @@ (match km [(kind-max ids actual) (define-values (bvals unbound-ids) - (for/fold ([bvals '()] [ubids (make-immutable-free-id-table)]) + (for/fold ([bvals '()] + [ubids (make-immutable-free-id-table)]) ([(id _) (in-free-id-table ids)]) (if (member id names) (values (cons (contract-restrict-value (lookup-id id)) bvals) ubids) (values bvals (free-id-table-set ubids id #t))))) (merge-kind-maxes 'flat (cons (kind-max unbound-ids actual) bvals))])) - + (define (instantiate-constraint con) - (match con - [(constraint km bound) - (constraint (instantiate-kind-max km) bound)])) - - (match cr - [(contract-restrict (kind-max ids max) rec constraints) - (define-values (bound-vals unbound-ids) - (for/fold ([bvs '()] [ubids (make-immutable-free-id-table)]) - ([(id _) (in-free-id-table ids)]) - (if (member id names) - (values (cons (lookup-id id) bvs) ubids) - (values bvs (free-id-table-set ubids id #t))))) - (merge-restricts* 'flat (cons - (contract-restrict - (kind-max unbound-ids max) - rec - (for*/set ([c (in-immutable-set constraints)] - [ic (in-value (instantiate-constraint c))] - #:when (not (trivial-constraint? ic))) - ic)) - bound-vals))])) + (match-define (constraint km bound) con) + (constraint (instantiate-kind-max km) bound)) + (match-define (contract-restrict (kind-max ids max) rec constraints) cr) + (define-values (bound-vals unbound-ids) + (for/fold ([bvs '()] + [ubids (make-immutable-free-id-table)]) + ([(id _) (in-free-id-table ids)]) + (if (member id names) + (values (cons (lookup-id id) bvs) ubids) + (values bvs (free-id-table-set ubids id #t))))) + (merge-restricts* 'flat + (cons (contract-restrict (kind-max unbound-ids max) + rec + (for*/set ([c (in-immutable-set constraints)] + [ic (in-value (instantiate-constraint c))] + #:when (not (trivial-constraint? ic))) + ic)) + bound-vals))) (for ([name (in-list names)] [cr (in-list crs)]) diff --git a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt index 9c34ac617..a81a17973 100644 --- a/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt @@ -2,24 +2,23 @@ ;; Provides functionality to take a static contract and turn it into a regular contract. -(require - "../utils/utils.rkt" - racket/match - racket/list - racket/contract - racket/syntax - syntax/private/id-table - (for-template racket/base racket/contract) - "combinators.rkt" - "combinators/name.rkt" - "combinators/case-lambda.rkt" - "combinators/parametric.rkt" - "kinds.rkt" - "optimize.rkt" - "parametric-check.rkt" - "structures.rkt" - "constraints.rkt" - "equations.rkt") +(require (for-template racket/base racket/contract) + racket/contract + racket/list + racket/match + racket/syntax + syntax/private/id-table + "../utils/utils.rkt" + "combinators.rkt" + "combinators/case-lambda.rkt" + "combinators/name.rkt" + "combinators/parametric.rkt" + "constraints.rkt" + "equations.rkt" + "kinds.rkt" + "optimize.rkt" + "parametric-check.rkt" + "structures.rkt") (provide static-contract-may-contain-free-ids?) @@ -145,12 +144,14 @@ (variable-ref (hash-ref vars id))) (for ([(name v) (in-free-id-table recursives)]) - (match v - [(kind-max others max) - (add-equation! eqs - (hash-ref vars name) - (λ () (apply combine-kinds max (for/list ([(id _) (in-free-id-table others)]) - (lookup id)))))])) + (match-define (kind-max others max) v) + (add-equation! eqs + (hash-ref vars name) + (λ () + (apply combine-kinds + max + (for/list ([(id _) (in-free-id-table others)]) + (lookup id)))))) (define var-values (resolve-equations eqs)) (for/hash ([(name var) (in-hash vars)]) (values name (hash-ref var-values var)))) diff --git a/typed-racket-lib/typed-racket/static-contracts/structures.rkt b/typed-racket-lib/typed-racket/static-contracts/structures.rkt index e1a15e6af..5c433a4e8 100644 --- a/typed-racket-lib/typed-racket/static-contracts/structures.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/structures.rkt @@ -124,15 +124,13 @@ #:transparent #:methods gen:sc [(define (sc-map v f) - (match v - [(recursive-sc names values body) - (recursive-sc names (map (λ (v) (f v 'covariant)) values) (f body 'covariant))])) + (match-define (recursive-sc names values body) v) + (recursive-sc names (map (λ (v) (f v 'covariant)) values) (f body 'covariant))) (define (sc-traverse v f) - (match v - [(recursive-sc names values body) - (for-each (λ (v) (f v 'covariant)) values) - (f body 'covariant) - (void)])) + (match-define (recursive-sc names values body) v) + (for-each (λ (v) (f v 'covariant)) values) + (f body 'covariant) + (void)) (define (sc->constraints v f) (simple-contract-restrict 'impersonator))] #:methods gen:custom-write [(define write-proc recursive-sc-write-proc)])