diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt index d683e26ab..ed114db2b 100644 --- a/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -65,34 +65,28 @@ [indices (listof symbol?)]) #:transparent) (define (context-add-vars ctx vars) - (match ctx - [(context V X Y) - (context V (append vars X) Y)])) + (match-define (context V X Y) ctx) + (context V (append vars X) Y)) (define (context-add-var ctx var) - (match ctx - [(context V X Y) - (context V (cons var X) Y)])) + (match-define (context V X Y) ctx) + (context V (cons var X) Y)) (define (context-add ctx #:bounds [bounds empty] #:vars [vars empty] #:indices [indices empty]) - (match ctx - [(context V X Y) - (context (append bounds V) (append vars X) (append indices Y))])) + (match-define (context V X Y) ctx) + (context (append bounds V) (append vars X) (append indices Y))) (define (inferable-index? ctx bound) - (match ctx - [(context _ _ Y) - (memq bound Y)])) + (match-define (context _ _ Y) ctx) + (memq bound Y)) (define ((inferable-var? ctx) var) - (match ctx - [(context _ X _) - (memq var X)])) + (match-define (context _ X _) ctx) + (memq var X)) (define (empty-cset/context ctx) - (match ctx - [(context _ X Y) - (empty-cset X Y)])) + (match-define (context _ X Y) ctx) + (empty-cset X Y)) @@ -766,9 +760,8 @@ (list values -Nat))) (define type (for/or ([pred-type (in-list possibilities)]) - (match pred-type - [(list pred? type) - (and (pred? n) type)]))) + (match-define (list pred? type) pred-type) + (and (pred? n) type))) (cgen/seq context (seq (list type) -null-end) ts*)] ;; numeric? == #true [((Base-bits: #t _) (SequenceSeq: ts*)) @@ -915,16 +908,12 @@ ;; c : Constaint ;; variance : Variance (define (constraint->type v variance) - (match v - [(c S T) - (match variance - [(? variance:const?) S] - [(? variance:co?) S] - [(? variance:contra?) T] - [(? variance:inv?) (let ([gS (generalize S)]) - (if (subtype gS T) - gS - S))])])) + (match-define (c S T) v) + (match variance + [(? variance:const?) S] + [(? variance:co?) S] + [(? variance:contra?) T] + [(? variance:inv?) (let ([gS (generalize S)]) (if (subtype gS T) gS S))])) ;; Since we don't add entries to the empty cset for index variables (since there is no ;; widest constraint, due to dcon-exacts), we must add substitutions here if no constraint @@ -934,14 +923,14 @@ (hash-union (for/hash ([v (in-list Y)] #:unless (hash-has-key? S v)) - (let ([var (hash-ref idx-hash v variance:const)]) - (values v - (match var - [(? variance:const?) (i-subst null)] - [(? variance:co?) (i-subst null)] - [(? variance:contra?) (i-subst/starred null Univ)] - ;; TODO figure out if there is a better subst here - [(? variance:inv?) (i-subst null)])))) + (define var (hash-ref idx-hash v variance:const)) + (values v + (match var + [(? variance:const?) (i-subst null)] + [(? variance:co?) (i-subst null)] + [(? variance:contra?) (i-subst/starred null Univ)] + ;; TODO figure out if there is a better subst here + [(? variance:inv?) (i-subst null)]))) S)) (define (build-subst m) (match m diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt index 2e3a5f0cd..2d06c91c0 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt @@ -45,12 +45,15 @@ (arr-seq-sc-map f (combinator-args v)) (void)) (define (sc->contract v f) - (match v - [(arr-combinator (arr-seq args rest range)) - (with-syntax ([(arg-stx ...) (map f args)] - [(rest-stx ...) (if rest #`(#:rest #,(f rest)) #'())] - [range-stx (if range #`(values #,@(map f range)) #'any)]) - #'(arg-stx ... rest-stx ... . -> . range-stx))])) + (match-define (arr-combinator (arr-seq args rest range)) v) + (with-syntax ([(arg-stx ...) (map f args)] + [(rest-stx ...) (if rest + #`(#:rest #,(f rest)) + #'())] + [range-stx (if range + #`(values #,@(map f range)) + #'any)]) + #'(arg-stx ... rest-stx ... . -> . range-stx))) (define (sc->constraints v f) (merge-restricts* 'chaperone (map f (arr-seq->list (combinator-args v)))))]) @@ -66,20 +69,18 @@ (define (arr-seq-sc-map f seq) - (match seq - [(arr-seq args rest range) - (arr-seq - (map (λ (a) (f a 'contravariant)) args) - (and rest (f rest 'contravariant)) - (and range (map (λ (a) (f a 'covariant)) range)))])) + (match-define (arr-seq args rest range) seq) + (arr-seq (map (λ (a) (f a 'contravariant)) args) + (and rest (f rest 'contravariant)) + (and range (map (λ (a) (f a 'covariant)) range)))) (define (arr-seq->list seq) - (match seq - [(arr-seq args rest range) - (append - args - (if rest (list rest) empty) - (or range empty))])) + (match-define (arr-seq args rest range) seq) + (append args + (if rest + (list rest) + empty) + (or range empty))) (struct arr-seq (args rest range) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt index 0b35fc476..7eec8f2ac 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/control.rkt @@ -24,14 +24,12 @@ (pt-seq-map f (combinator-args v)) (void)) (define (sc->contract v f) - (match v - [(prompt-tag-combinator (pt-seq vals call-cc)) - (with-syntax ([(vals-stx ...) (map f vals)] - [(call-cc-stx ...) - (if call-cc - #`(#:call/cc (values #,@(map f call-cc))) - empty)]) - #'(prompt-tag/c vals-stx ... call-cc-stx ...))])) + (match-define (prompt-tag-combinator (pt-seq vals call-cc)) v) + (with-syntax ([(vals-stx ...) (map f vals)] + [(call-cc-stx ...) (if call-cc + #`(#:call/cc (values #,@(map f call-cc))) + empty)]) + #'(prompt-tag/c vals-stx ... call-cc-stx ...))) (define (sc->constraints v f) (merge-restricts* 'chaperone (map f (pt-seq->list (combinator-args v)))))]) @@ -52,16 +50,11 @@ (define (pt-seq-map f seq) - (match seq - [(pt-seq vals call-cc) - (define (f* a) (f a 'invariant)) - (pt-seq - (map f* vals) - (and call-cc (map f* call-cc)))])) + (match-define (pt-seq vals call-cc) seq) + (define (f* a) + (f a 'invariant)) + (pt-seq (map f* vals) (and call-cc (map f* call-cc)))) (define (pt-seq->list seq) - (match seq - [(pt-seq vals call-cc) - (append - vals - (or call-cc empty))])) + (match-define (pt-seq vals call-cc) seq) + (append vals (or call-cc empty))) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/dep-function.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/dep-function.rkt index 9a819f23c..5d7bbcbc9 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/dep-function.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/dep-function.rkt @@ -25,64 +25,63 @@ #:property prop:combinator-name "dep->/sc" #:methods gen:sc [(define (sc->contract v rec) - (match v - [(->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) - (with-syntax ([(id ...) ids] - [(c ...) (for/list ([d/sc (in-list dom/scs)] - [dep-ids (in-list dom-deps)]) - (cond - [(not (null? dep-ids)) - (parameterize ([static-contract-may-contain-free-ids? #t]) - (rec d/sc))] - [else (rec d/sc)]))] - [(dep ...) dom-deps] - [(r-deps ...) rng-deps] - [(p-deps ...) pre-deps]) - #`(->i ([id dep c] ...) - #,@(cond - [(not pre) #'()] - [else #`(#:pre (p-deps ...) - #,(cond - [(not (null? pre-deps)) - (parameterize ([static-contract-may-contain-free-ids? #t]) - (rec pre))] - [else (rec pre)]))]) - #,(cond - [(and typed-side? (andmap any/sc? rng-deps)) #'any] - [(null? rng-deps) - #`[_ () (values #,@(map rec rng/scs))]] - [else - (parameterize ([static-contract-may-contain-free-ids? #t]) - #`[_ (r-deps ...) (values #,@(map rec rng/scs))])])))])) + (match-define (->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) v) + (with-syntax ([(id ...) ids] + [(c ...) (for/list ([d/sc (in-list dom/scs)] + [dep-ids (in-list dom-deps)]) + (cond + [(not (null? dep-ids)) + (parameterize ([static-contract-may-contain-free-ids? #t]) + (rec d/sc))] + [else (rec d/sc)]))] + [(dep ...) dom-deps] + [(r-deps ...) rng-deps] + [(p-deps ...) pre-deps]) + #`(->i ([id dep c] ...) + #,@(cond + [(not pre) #'()] + [else + #`(#:pre (p-deps ...) + #,(cond + [(not (null? pre-deps)) + (parameterize ([static-contract-may-contain-free-ids? #t]) + (rec pre))] + [else (rec pre)]))]) + #,(cond + [(and typed-side? (andmap any/sc? rng-deps)) #'any] + [(null? rng-deps) #`[_ () (values #,@(map rec rng/scs))]] + [else + (parameterize ([static-contract-may-contain-free-ids? #t]) + #`[_ (r-deps ...) (values #,@(map rec rng/scs))])])))) (define (sc-map v f) - (match v - [(->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) - (->i/sc typed-side? - ids - (for/list ([d/sc (in-list dom/scs)]) - (f d/sc 'contravariant)) - dom-deps - (and pre (f pre 'contravariant)) - pre-deps - (for/list ([r/sc (in-list rng/scs)]) - (f r/sc 'covariant)) - rng-deps)])) + (match-define (->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) v) + (->i/sc typed-side? + ids + (for/list ([d/sc (in-list dom/scs)]) + (f d/sc 'contravariant)) + dom-deps + (and pre (f pre 'contravariant)) + pre-deps + (for/list ([r/sc (in-list rng/scs)]) + (f r/sc 'covariant)) + rng-deps)) (define (sc-traverse v f) - (match v - [(->i/sc _ _ dom/scs _ pre _ rng/scs _) - (for ([d/sc (in-list dom/scs)]) - (f d/sc 'contravariant)) - (when pre (f pre 'contravariant)) - (for ([r/sc (in-list rng/scs)]) - (f r/sc 'covariant))])) + (match-define (->i/sc _ _ dom/scs _ pre _ rng/scs _) v) + (for ([d/sc (in-list dom/scs)]) + (f d/sc 'contravariant)) + (when pre + (f pre 'contravariant)) + (for ([r/sc (in-list rng/scs)]) + (f r/sc 'covariant))) (define (sc-terminal-kind v) 'impersonator) (define (sc->constraints v f) - (match v - [(->i/sc _ _ dom/scs _ pre _ rng/scs _) - (merge-restricts* 'impersonator - (append (if pre (list (f pre)) (list)) - (map f rng/scs) - (map f dom/scs)))]))]) + (match-define (->i/sc _ _ dom/scs _ pre _ rng/scs _) v) + (merge-restricts* 'impersonator + (append (if pre + (list (f pre)) + (list)) + (map f rng/scs) + (map f dom/scs))))]) (require-for-cond-contract "proposition.rkt") diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/exist.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/exist.rkt index 0f16fc24f..fd14ce2a6 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/exist.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/exist.rkt @@ -29,12 +29,10 @@ (define (sc->contract v f) (match-define (exist-combinator (list names doms rngs)) v) (parameterize ([static-contract-may-contain-free-ids? #t]) - (define a - (with-syntax ([doms-stx (f doms)] - [rngs-stx (f rngs)] - [n (car names)]) - #'(->i ([n doms-stx]) (_ (n) rngs-stx)))) - a)) + (with-syntax ([doms-stx (f doms)] + [rngs-stx (f rngs)] + [n (car names)]) + #'(->i ([n doms-stx]) (_ (n) rngs-stx))))) (define (sc->constraints v f) (simple-contract-restrict 'flat))]) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt index 6535c1aa9..d67f007ee 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/function.rkt @@ -146,13 +146,10 @@ (match-define (function-combinator args indices mand-kws opt-kws typed-side?) v) (define-values (mand-args opt-args mand-kw-args opt-kw-args rest-arg range-args) (apply split-function-args args indices)) - (if (and (not rest-arg) - (null? (append mand-kw-args mand-args opt-kw-args opt-args)) - typed-side?) - ;; currently we only handle this trivial case - ;; we could probably look at the actual kind of `range-args` as well - (if (not range-args) 'flat #f) - #f)) + (and (and (not rest-arg) (null? (append mand-kw-args mand-args opt-kw-args opt-args)) typed-side?) + ;; currently we only handle this trivial case + ;; we could probably look at the actual kind of `range-args` as well + (if (not range-args) 'flat #f))) (define (function-sc-constraints v f) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt index aaf0e2ecf..85502d02e 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/object.rkt @@ -42,14 +42,12 @@ #:property prop:combinator-name "class/sc" #:methods gen:sc [(define (sc-map v f) - (match v - [(class-combinator args opaque absents) - (class-combinator (member-seq-sc-map f args) opaque absents)])) + (match-define (class-combinator args opaque absents) v) + (class-combinator (member-seq-sc-map f args) opaque absents)) (define (sc-traverse v f) - (match v - [(class-combinator args opaque absents) - (member-seq-sc-map f args) - (void)])) + (match-define (class-combinator args opaque absents) v) + (member-seq-sc-map f args) + (void)) (define (sc->contract v f) (class/sc->contract v f)) (define (sc->constraints v f) @@ -60,20 +58,17 @@ #:property prop:combinator-name "instanceof/sc" #:methods gen:sc [(define (sc-map v f) - (match v - [(instanceof-combinator (list class)) - (instanceof-combinator (list (f class 'covariant)))])) + (match-define (instanceof-combinator (list class)) v) + (instanceof-combinator (list (f class 'covariant)))) (define (sc-traverse v f) - (match v - [(instanceof-combinator (list class)) - (f class 'covariant) - (void)])) + (match-define (instanceof-combinator (list class)) v) + (f class 'covariant) + (void)) (define (sc->contract v f) (instance/sc->contract v f)) (define (sc->constraints v f) - (match v - [(instanceof-combinator (list class)) - (f class)]))]) + (match-define (instanceof-combinator (list class)) v) + (f class))]) (define member-seq->list @@ -86,13 +81,10 @@ #:property prop:sequence member-seq->list) (define (member-seq-sc-map f seq) - (match seq - [(member-seq vals) - (member-seq - (for/list ([v (in-list vals)]) - (match v - [(member-spec mod id sc) - (member-spec mod id (and sc (f sc 'invariant)))])))])) + (match-define (member-seq vals) seq) + (member-seq (for/list ([v (in-list vals)]) + (match v + [(member-spec mod id sc) (member-spec mod id (and sc (f sc 'invariant)))])))) ;; TODO make this the correct subset (define object-member-spec? member-spec?) @@ -105,14 +97,15 @@ (instanceof-combinator (list class))) (define ((member-spec->form f) v) - (match v - [(member-spec modifier id sc) - (with-syntax ([id/ctc (if sc #`(#,id #,(f sc)) id)]) - (case modifier - [(method) #'id/ctc] - [(inner) #'(inner id/ctc)] - [(init) #'(init id/ctc)] - [(field) #'(field id/ctc)]))])) + (match-define (member-spec modifier id sc) v) + (with-syntax ([id/ctc (if sc + #`(#,id #,(f sc)) + id)]) + (case modifier + [(method) #'id/ctc] + [(inner) #'(inner id/ctc)] + [(init) #'(init id/ctc)] + [(field) #'(field id/ctc)]))) (define (spec->id/ctc f modifier vals) (for/lists (_1 _2) @@ -122,50 +115,39 @@ (f (member-spec-sc spec))))) (define (object/sc->contract v f) - (match v - [(object-combinator (member-seq vals) opaque?) - #`(#,(if opaque? - #'object/c-opaque - #'object/c) - #,@(map (member-spec->form f) vals))])) - -(define (class/sc->contract v f) - (match v - [(class-combinator (member-seq vals) opaque absents) - (define-values (override-names override-ctcs) - (spec->id/ctc f 'override vals)) - (define-values (pubment-names pubment-ctcs) - (spec->id/ctc f 'pubment vals)) - (define/with-syntax (override-temp ...) - (generate-temporaries override-ctcs)) - (define/with-syntax (pubment-temp ...) - (generate-temporaries pubment-ctcs)) - (define/with-syntax (override-name ...) override-names) - (define/with-syntax (pubment-name ...) pubment-names) - (define/with-syntax (override-ctc ...) override-ctcs) - (define/with-syntax (pubment-ctc ...) pubment-ctcs) - (define vals-rest - (filter (λ (spec) - (not (memq (member-spec-modifier spec) - '(override pubment)))) - vals)) - #`(let ([override-temp override-ctc] ... - [pubment-temp pubment-ctc] ...) - (class/c #,@(if opaque '(#:opaque #:ignore-local-member-names) null) - #,@(map (member-spec->form f) vals-rest) - [override-name override-temp] ... - (override [override-name override-temp] ...) - (super [override-name override-temp] ...) - (inherit [override-name override-temp] ...) - [pubment-name pubment-temp] ... - (augment [pubment-name pubment-temp] ...) - (inherit [pubment-name pubment-temp] ...) - (absent #,@absents)))])) + (match-define (object-combinator (member-seq vals) opaque?) v) + #`(#,(if opaque? #'object/c-opaque #'object/c) #,@(map (member-spec->form f) vals))) + +(define (class/sc->contract v f) + (match-define (class-combinator (member-seq vals) opaque absents) v) + (define-values (override-names override-ctcs) (spec->id/ctc f 'override vals)) + (define-values (pubment-names pubment-ctcs) (spec->id/ctc f 'pubment vals)) + (define/with-syntax (override-temp ...) (generate-temporaries override-ctcs)) + (define/with-syntax (pubment-temp ...) (generate-temporaries pubment-ctcs)) + (define/with-syntax (override-name ...) override-names) + (define/with-syntax (pubment-name ...) pubment-names) + (define/with-syntax (override-ctc ...) override-ctcs) + (define/with-syntax (pubment-ctc ...) pubment-ctcs) + (define vals-rest + (filter (λ (spec) (not (memq (member-spec-modifier spec) '(override pubment)))) vals)) + #`(let ([override-temp override-ctc] ... + [pubment-temp pubment-ctc] ...) + (class/c #,@(if opaque + '(#:opaque #:ignore-local-member-names) + null) + #,@(map (member-spec->form f) vals-rest) + [override-name override-temp] ... + (override [override-name override-temp] ...) + (super [override-name override-temp] ...) + (inherit [override-name override-temp] ...) + [pubment-name pubment-temp] ... + (augment [pubment-name pubment-temp] ...) + (inherit [pubment-name pubment-temp] ...) + (absent #,@absents)))) (define (instance/sc->contract v f) - (match v - [(instanceof-combinator (list class)) - #`(instanceof/c #,(f class))])) + (match-define (instanceof-combinator (list class)) v) + #`(instanceof/c #,(f class))) (define (make-class-shape/sc init* field* public* augment*) (define-values [pubment* override*] (partition (lambda (nm) (memq nm augment*)) public*)) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt index c167925ad..c407981fd 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/prefab.rkt @@ -23,33 +23,27 @@ #:property prop:combinator-name "prefab/sc" #:methods gen:sc [(define (sc-map v f) - (match v - [(prefab-combinator args key field-mutability) - (prefab-combinator (map (λ (a mut?) (f a (if mut? 'invariant 'covariant))) - args - field-mutability) - key - field-mutability)])) + (match-define (prefab-combinator args key field-mutability) v) + (prefab-combinator + (map (λ (a mut?) (f a (if mut? 'invariant 'covariant))) args field-mutability) + key + field-mutability)) (define (sc-traverse v f) - (match v - [(prefab-combinator args key field-mutability) - (for-each (λ (a mut?) (f a (if mut? 'invariant 'covariant))) - args - field-mutability) - (void)])) + (match-define (prefab-combinator args key field-mutability) v) + (for-each (λ (a mut?) (f a (if mut? 'invariant 'covariant))) args field-mutability) + (void)) (define (sc->contract v f) - (match v - [(prefab-combinator args key _) - #`(prefab/c (quote #,(abbreviate-prefab-key key)) #,@(map f args))])) + (match-define (prefab-combinator args key _) v) + #`(prefab/c (quote #,(abbreviate-prefab-key key)) #,@(map f args))) (define (sc->constraints v f) - (match v - [(prefab-combinator args _ field-mutability) - (merge-restricts* - (if (ormap values field-mutability) 'chaperone 'flat) - (map (λ (a mut?) - (if (not mut?) (add-constraint (f a) 'chaperone) (f a))) - args - field-mutability))]))]) + (match-define (prefab-combinator args _ field-mutability) v) + (merge-restricts* (if (ormap values field-mutability) 'chaperone 'flat) + (map (λ (a mut?) + (if (not mut?) + (add-constraint (f a) 'chaperone) + (f a))) + args + field-mutability)))]) (define (prefab/sc key fields) (prefab-combinator fields key (prefab-key->field-mutability key))) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt index 3b80efef7..cc4b0b989 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt @@ -35,12 +35,10 @@ ;; ;; Note: does not handle cycles but there shouldn't be any (define (stx-equal? s1 s2) - (cond [(and (identifier? s1) (identifier? s2)) - (free-identifier=? s1 s2)] - [else - (if (and (syntax? s1) (syntax? s2)) - (equal?/recur (syntax-e s1) (syntax-e s2) stx-equal?) - (equal?/recur s1 s2 stx-equal?))])) + (cond + [(and (identifier? s1) (identifier? s2)) (free-identifier=? s1 s2)] + [(and (syntax? s1) (syntax? s2)) (equal?/recur (syntax-e s1) (syntax-e s2) stx-equal?)] + [else (equal?/recur s1 s2 stx-equal?)])) (struct simple-contract static-contract (syntax kind name) #:transparent diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt index 05da781aa..2e10062a9 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt @@ -26,28 +26,23 @@ #:property prop:combinator-name "struct/sc" #:methods gen:sc [(define (sc-map v f) - (match v - [(struct-combinator args name mut?) - (struct-combinator (map (λ (a) (f a (if mut? 'invariant 'covariant))) args) - name mut?)])) + (match-define (struct-combinator args name mut?) v) + (struct-combinator (map (λ (a) (f a (if mut? 'invariant 'covariant))) args) name mut?)) (define (sc-traverse v f) - (match v - [(struct-combinator args name mut?) - (for-each (λ (a) (f a (if mut? 'invariant 'covariant))) args) - (void)])) + (match-define (struct-combinator args name mut?) v) + (for-each (λ (a) (f a (if mut? 'invariant 'covariant))) args) + (void)) (define (sc->contract v f) - (match v - [(struct-combinator args name _) - #`(struct/c #,name #,@(map f args))])) + (match-define (struct-combinator args name _) v) + #`(struct/c #,name #,@(map f args))) (define (sc->constraints v f) - (match v - [(struct-combinator args _ mut?) - (merge-restricts* (if mut? 'chaperone 'flat) - (map (lambda (a) - (if (not mut?) - (add-constraint (f a) 'chaperone) - (f a))) - args))]))]) + (match-define (struct-combinator args _ mut?) v) + (merge-restricts* (if mut? 'chaperone 'flat) + (map (lambda (a) + (if (not mut?) + (add-constraint (f a) 'chaperone) + (f a))) + args)))]) (define (struct/sc name mut? fields) (struct-combinator fields name mut?)) @@ -64,21 +59,18 @@ #:property prop:combinator-name "struct-type/sc" #:methods gen:sc [(define (sc-map v f) - (match v - [(struct-type/sc args) - (struct-type/sc (map (λ (a) (f a 'covariant)) args))])) + (match-define (struct-type/sc args) v) + (struct-type/sc (map (λ (a) (f a 'covariant)) args))) (define (sc-traverse v f) - (match v - [(struct-type/sc args) - (for-each (λ (a) (f a 'covariant)) args) - (void)])) + (match-define (struct-type/sc args) v) + (for-each (λ (a) (f a 'covariant)) args) + (void)) (define (sc->contract v f) - (match v - [(struct-type/sc args) - #`(struct-type/c #f)])) + (match-define (struct-type/sc args) v) + #`(struct-type/c #f)) (define (sc->constraints v f) - (match v - [(struct-type/sc args) (simple-contract-restrict 'chaperone)]))]) + (match-define (struct-type/sc args) v) + (simple-contract-restrict 'chaperone))]) (define-match-expander struct-type/sc: (syntax-parser diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt index e78f7082b..684bb3401 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt @@ -3,26 +3,29 @@ ;; Static contracts for structural contracts. ;; Ex: list/sc, vectorof/sc -(require "../../utils/utils.rkt" - "../structures.rkt" - "../constraints.rkt" - racket/match - (for-syntax racket/base racket/syntax syntax/stx syntax/parse) - racket/set - racket/sequence - (for-template racket/base +(require (for-syntax racket/base + racket/syntax + syntax/parse + syntax/stx) + (for-template racket/async-channel + racket/base racket/contract/base - racket/set - racket/async-channel - racket/sequence racket/promise + racket/sequence + racket/set "../../utils/evt-contract.rkt" "../../utils/hash-contract.rkt" + "../../utils/promise-not-name-contract.rkt" "../../utils/shallow-contract.rkt" - "../../utils/vector-contract.rkt" - "../../utils/promise-not-name-contract.rkt") + "../../utils/vector-contract.rkt") + racket/async-channel racket/contract - racket/async-channel) + racket/match + racket/sequence + racket/set + "../../utils/utils.rkt" + "../constraints.rkt" + "../structures.rkt") (begin-for-syntax diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt index 766f66666..8ea8181bf 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/unit.rkt @@ -16,15 +16,13 @@ #:transparent #:property prop:combinator-name "unit/sc" #:methods gen:sc - [(define (sc-map v f) - (match v - [(unit-combinator unit-spec) - (unit-combinator (unit-spec-sc-map f unit-spec))])) + [(define (sc-map v f) + (match-define (unit-combinator unit-spec) v) + (unit-combinator (unit-spec-sc-map f unit-spec))) (define (sc-traverse v f) - (match v - [(unit-combinator unit-spec) - (unit-spec-sc-map f unit-spec) - (void)])) + (match-define (unit-combinator unit-spec) v) + (unit-spec-sc-map f unit-spec) + (void)) (define (sc->contract v f) (unit/sc->contract v f)) (define (sc->constraints v f) @@ -44,53 +42,41 @@ #:property prop:sequence unit-spec->list) (define (unit-spec-sc-map f seq) - (match seq - [(unit-spec imports exports init-depends invokes) - (unit-spec - (map (signature-spec-sc-map f) imports) - (map (signature-spec-sc-map f) exports) - ;; leave init-depends alone since they don't contain contracts - init-depends - (map (lambda (invoke) (and invoke (f invoke 'covariant))) invokes))])) + (match-define (unit-spec imports exports init-depends invokes) seq) + (unit-spec (map (signature-spec-sc-map f) imports) + (map (signature-spec-sc-map f) exports) + ;; leave init-depends alone since they don't contain contracts + init-depends + (map (lambda (invoke) (and invoke (f invoke 'covariant))) invokes))) (define ((signature-spec-sc-map f) seq) - (match seq - [(signature-spec name (list ids ...) (list scs ...)) - (signature-spec - name - ids - (map (lambda (sc) (and sc (f sc 'invariant))) scs))])) + (match-define (signature-spec name (list ids ...) (list scs ...)) seq) + (signature-spec name ids (map (lambda (sc) (and sc (f sc 'invariant))) scs))) (define (unit/sc->contract v f) - (match v - [(unit-combinator - (unit-spec (list imports ...) - (list exports ...) - (list deps ...) - (list invoke/scs ...))) - - (define (sig-spec->syntax sig-spec) - (match sig-spec - [(signature-spec name members scs) - (define member-stx - (map (lambda (id sc) #`(#,id #,(f sc))) members scs)) - #`(#,name #,@member-stx)])) - - (define (invokes->contract lst) - (cond - ;; just a single contract - [(= 1 (length lst)) - #`#,(f (first lst))] - ;; values contract - [else - #`(values #,@(map f lst))])) - - #`(unit/c - (import #,@(map sig-spec->syntax imports)) - (export #,@(map sig-spec->syntax exports)) - (init-depend #,@deps) - #,(invokes->contract invoke/scs))])) + (match-define (unit-combinator (unit-spec (list imports ...) + (list exports ...) + (list deps ...) + (list invoke/scs ...))) + v) + (define (sig-spec->syntax sig-spec) + (match sig-spec + [(signature-spec name members scs) + (define member-stx (map (lambda (id sc) #`(#,id #,(f sc))) members scs)) + #`(#,name #,@member-stx)])) + + (define (invokes->contract lst) + (cond + ;; just a single contract + [(= 1 (length lst)) #`#,(f (first lst))] + ;; values contract + [else #`(values #,@(map f lst))])) + + #`(unit/c (import #,@(map sig-spec->syntax imports)) + (export #,@(map sig-spec->syntax exports)) + (init-depend #,@deps) + #,(invokes->contract invoke/scs))) (define (unit/sc imports exports init-depends invoke) (unit-combinator (unit-spec imports exports init-depends invoke)))