diff --git a/pkgs/racket-doc/scribblings/reference/sets.scrbl b/pkgs/racket-doc/scribblings/reference/sets.scrbl index 03b10fd6ae..ff5523751f 100644 --- a/pkgs/racket-doc/scribblings/reference/sets.scrbl +++ b/pkgs/racket-doc/scribblings/reference/sets.scrbl @@ -203,17 +203,20 @@ named by the @racket[sym]s. 'dont-care] [#:kind kind (or/c 'dont-care 'immutable 'mutable 'weak 'mutable-or-weak) - 'immutable]) + 'immutable] + [#:lazy? lazy? any/c + (not (and (equal? kind 'immutable) + (flat-contract? elem/c)))]) contract?]{ Constructs a contract that recognizes sets whose elements match - @racket[contract]. + @racket[elem/c]. If @racket[kind] is @racket['immutable], @racket['mutable], or @racket['weak], the resulting contract accepts only @tech{hash sets} that are respectively immutable, mutable with strongly-held keys, or mutable with weakly-held keys. If @racket[kind] is @racket['mutable-or-weak], the - resulting contract accepts any mutable @racket{hash sets}, regardless of + resulting contract accepts any mutable @tech{hash sets}, regardless of key-holding strength. If @racket[cmp] is @racket['equal], @racket['eqv], or @racket['eq], the @@ -221,12 +224,30 @@ named by the @racket[sym]s. using @racket[equal?], @racket[eqv?], or @racket[eq?], respectively. If @racket[cmp] is @racket['eqv] or @racket['eq], then @racket[elem/c] must - be a flat contract. + be a @tech{flat contract}. If @racket[cmp] and @racket[kind] are both @racket['dont-care], then the resulting contract will accept any kind of set, not just @tech{hash sets}. + If @racket[lazy?] is not @racket[#f], then the elements of the set are not checked + immediately by the contract and only the set itself is checked (according to the + @racket[cmp] and @racket[kind] arguments). If @racket[lazy?] is + @racket[#f], then the elements are checked immediately by the contract. + The @racket[lazy?] argument is ignored when the set contract accepts generic sets + (i.e., when @racket[cmp] and @racket[kind] are both @racket['dont-care]); in that + case, the value being checked in that case is a @racket[list?], then the contract + is not lazy otherwise the contract is lazy. + + If @racket[kind] allows mutable sets (i.e., is @racket['dont-care], + @racket['mutable], @racket['weak], or + @racket['mutable-or-weak]) and @racket[lazy?] is @racket[#f], then the elements + are checked both immediately and when they are accessed from the set. + + The result contract will be a @tech{flat contract} when @racket[elem/c] is a @tech{flat + contract}, @racket[lazy?] is @racket[#f], and @racket[kind] is @racket['immutable]. + The result will be a @tech{chaperone contract} when @racket[elem/c] is a + @tech{chaperone contract}. } @section{Generic Set Interface} diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index d81b3b79ed..a035a9d0cb 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -393,7 +393,8 @@ (test-name '(set/c char? #:cmp 'eq) (set/c char? #:cmp 'eq)) (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv)) (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) - + (test-name '(set/c (-> integer? boolean?)) (set/c (-> integer? boolean?))) + (test-name 'α (let ([α (new-∀/c)]) α)) (test-name 'α (let ([α (new-∀/c #f)]) α)) (test-name 'β (let ([α (new-∀/c 'β)]) α)) diff --git a/pkgs/racket-test/tests/racket/contract/set.rkt b/pkgs/racket-test/tests/racket/contract/set.rkt index c64b97e3df..a5a0c150d0 100644 --- a/pkgs/racket-test/tests/racket/contract/set.rkt +++ b/pkgs/racket-test/tests/racket/contract/set.rkt @@ -109,4 +109,112 @@ '(contract (set/c integer? #:kind 'mutable) (mutable-set 0) 'pos 'neg) - (contract-eval '(mutable-set 0)))) + (contract-eval '(mutable-set 0))) + + + (test/pos-blame + 'set/c17 + '(let () + (struct binary-set [integer] + #:transparent + #:methods gen:set + [(define (set-member? st i) + (bitwise-bit-set? (binary-set-integer st) i)) + (define (set-add st i) + (binary-set (bitwise-ior (binary-set-integer st) + (arithmetic-shift 1 i)))) + (define (set-remove st i) + (binary-set (bitwise-and (binary-set-integer st) + (bitwise-not (arithmetic-shift 1 i)))))]) + (contract (set/c integer?) + (binary-set 5) + 'pos 'neg))) + + (test/spec-passed + 'set/c19 + '(let () + (struct binary-set [integer] + #:transparent + #:methods gen:set + [(define (set-member? st i) + (bitwise-bit-set? (binary-set-integer st) i)) + (define (set-add st i) + (binary-set (bitwise-ior (binary-set-integer st) + (arithmetic-shift 1 i)))) + (define (set-remove st i) + (binary-set (bitwise-and (binary-set-integer st) + (bitwise-not (arithmetic-shift 1 i)))))]) + (contract (set/c integer? #:kind 'dont-care) + (binary-set 5) + 'pos 'neg))) + + (test/spec-passed + 'set/c20 + '(let () + (struct binary-set [integer] + #:transparent + #:methods gen:set + [(define (set-member? st i) + (bitwise-bit-set? (binary-set-integer st) i)) + (define (set-add st i) + (binary-set (bitwise-ior (binary-set-integer st) + (arithmetic-shift 1 i)))) + (define (set-remove st i) + (binary-set (bitwise-and (binary-set-integer st) + (bitwise-not (arithmetic-shift 1 i)))))]) + (contract (set/c boolean? #:kind 'dont-care #:lazy? #t) + (binary-set 5) + 'pos 'neg))) + + (test/spec-passed + 'set/c21 + '(let* ([c (set/c (-> integer? integer?))] + [s (contract c (set (λ (x) x)) 'pos 'neg)]) + (and (has-contract? s) + (equal? (value-contract s) c)))) + + (test/spec-passed + 'set/c22 + '(contract (set/c (-> integer? integer?) #:lazy? #t) + (set #f) 'pos 'neg)) + + (test/pos-blame + 'set/c23 + '(set-first + (contract (set/c (-> integer? integer?) #:lazy? #t) + (set #f) 'pos 'neg))) + + (test/pos-blame + 'set/c24 + '(contract (set/c (-> integer? integer?) #:lazy? #f) + (set #f) 'pos 'neg)) + + (test/spec-passed + 'set/c25 + '(contract (set/c integer? #:lazy? #t) + (set #f) 'pos 'neg)) + + (test/pos-blame + 'set/c26 + '(set-first + (contract (set/c integer? #:lazy? #t) + (set #f) 'pos 'neg))) + + (test/pos-blame + 'set/c27 + '(contract (set/c integer? #:lazy? #f) + (set #f) 'pos 'neg)) + + (test/neg-blame + 'set/c28 + '(let ([s (contract (set/c integer? #:lazy? #t) + (set #f) 'pos 'neg)]) + (set-add! s "x"))) + + (test/neg-blame + 'set/c29 + '(let ([s (contract (set/c integer? #:lazy? #f) + (set 0) 'pos 'neg)]) + (set-add! s "x"))) + + ) diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt index 60c9eb9068..d039e34a1d 100644 --- a/racket/collects/racket/set.rkt +++ b/racket/collects/racket/set.rkt @@ -12,9 +12,14 @@ (all-from-out racket/private/set-types) set/c) -(define (set/c elem/c - #:cmp [cmp 'dont-care] - #:kind [kind 'immutable]) +(define/subexpression-pos-prop/name + real-set/c-name (set/c elem/c + #:cmp [cmp 'dont-care] + #:kind [kind 'immutable] + #:lazy? [_lazy? + (not (and (equal? kind 'immutable) + (flat-contract? elem/c)))]) + (define lazy? (and _lazy? #t)) (define cmp/c (case cmp [(dont-care) any/c] @@ -22,8 +27,8 @@ [(eqv) set-eqv?] [(eq) set-eq?] [else (raise-arguments-error 'set/c - "invalid #:cmp argument" - "#:cmp argument" cmp)])) + "invalid #:cmp argument" + "#:cmp argument" cmp)])) (define kind/c (case kind [(dont-care) any/c] @@ -47,14 +52,15 @@ (raise-argument-error 'set/c "chaperone-contract?" elem/c))]) (cond [(and (eq? kind 'immutable) + (not lazy?) (flat-contract? elem/c)) - (flat-set-contract elem/c cmp kind)] + (flat-set-contract elem/c cmp kind lazy?)] [(chaperone-contract? elem/c) - (chaperone-set-contract elem/c cmp kind)] + (chaperone-set-contract elem/c cmp kind lazy?)] [else - (impersonator-set-contract elem/c cmp kind)])) + (impersonator-set-contract elem/c cmp kind lazy?)])) -(struct set-contract [elem/c cmp kind]) +(struct set-contract [elem/c cmp kind lazy?]) (define (set-contract-name ctc) (define elem/c (set-contract-elem/c ctc)) @@ -66,7 +72,11 @@ `[#:cmp (quote ,cmp)]) ,@(if (eq? kind 'immutable) `[] - `[#:kind (quote ,kind)]))) + `[#:kind (quote ,kind)]) + ,@(if (equal? (set-contract-lazy? ctc) + (flat-contract? elem/c)) + '() + `(#:lazy? ,(set-contract-lazy? ctc))))) (define (set-contract-first-order ctc) (define cmp (set-contract-cmp ctc)) @@ -116,83 +126,153 @@ (define (set-contract-late-neg-projection chaperone-ctc?) (lambda (ctc) - (define elem/c (set-contract-elem/c ctc)) - (define cmp (set-contract-cmp ctc)) - (define kind (set-contract-kind ctc)) - (lambda (blame) - (define (method sym c) - (define name (contract-name c)) - (define str (format "method ~a with contract ~.s" sym name)) - (define b2 (blame-add-context blame str)) - ((contract-late-neg-projection c) b2)) - (define-syntax (redirect stx) - (syntax-case stx () - [(_ [id expr] ...) - (with-syntax ([(proj-id ...) (generate-temporaries #'(id ...))]) - #'(let ([proj-id (method 'id expr)] ...) - (λ (x neg-party) - (redirect-generics chaperone-ctc? - gen:set x [id (λ (x) (proj-id x neg-party))] ...))))])) - (define me (if chaperone-contract? - (make-chaperone-contract - #:name (set-contract-name ctc) - #:stronger set-contract-stronger - #:late-neg-projection - (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))) - (make-contract - #:name (set-contract-name ctc) - #:stronger set-contract-stronger - #:late-neg-projection - (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))))) - (define do-redirect - (redirect - [set-member? (-> generic-set? elem/c boolean?)] - [set-empty? (or/c (-> generic-set? boolean?) #f)] - [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)] - [set=? (or/c (-> generic-set? me boolean?) #f)] - [subset? (or/c (-> generic-set? me boolean?) #f)] - [proper-subset? (or/c (-> generic-set? me boolean?) #f)] - [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)] - [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)] - [set-copy (or/c (-> generic-set? generic-set?) #f)] - [in-set (or/c (-> generic-set? sequence?) #f)] - [set->list (or/c (-> generic-set? (listof elem/c)) #f)] - [set->stream (or/c (-> generic-set? stream?) #f)] - [set-first (or/c (-> generic-set? elem/c) #f)] - [set-rest (or/c (-> generic-set? me) #f)] - [set-add (or/c (-> generic-set? elem/c me) #f)] - [set-remove (or/c (-> generic-set? elem/c me) #f)] - [set-clear (or/c (-> generic-set? me) #f)] - [set-copy-clear (or/c (-> generic-set? generic-set?) #f)] - [set-union - (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] - [set-intersect - (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] - [set-subtract - (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] - [set-symmetric-difference - (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] - [set-add! (or/c (-> generic-set? elem/c void?) #f)] - [set-remove! (or/c (-> generic-set? elem/c void?) #f)] - [set-clear! (or/c (-> generic-set? void?) #f)] - [set-union! - (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] - [set-intersect! - (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] - [set-subtract! - (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] - [set-symmetric-difference! - (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)])) - (define proj - ((contract-projection elem/c) - (blame-add-context blame "an element of"))) - (lambda (x neg-party) - (set-contract-check cmp kind blame neg-party x) + (cond + [(allows-generic-sets? ctc) + (generic-set-late-neg-projection ctc chaperone-ctc?)] + [else + (hash-set-late-neg-projection ctc chaperone-ctc?)]))) + +(define (allows-generic-sets? ctc) + (and (equal? 'dont-care (set-contract-kind ctc)) + (equal? 'dont-care (set-contract-cmp ctc)))) + +(define (hash-set-late-neg-projection ctc chaperone-ctc?) + (define elem/c (set-contract-elem/c ctc)) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) + (define late-neg-ele-proj (contract-late-neg-projection elem/c)) + (define lazy? (set-contract-lazy? ctc)) + (λ (blame) + (define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f))) + (define late-neg-neg-proj (late-neg-ele-proj (blame-add-element-context blame #t))) + (define set/c-lazy-late-neg-proj + (λ (val neg-party) + (set-contract-check cmp kind blame neg-party val) + (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party)) (cond - [(list? x) - (map proj x)] + [(set? val) + (chaperone-hash-set + val + pos-interpose + (λ (val ele) ele) + pos-interpose + impersonator-prop:contracted + ctc)] [else - (do-redirect x neg-party)]))))) + (chaperone-hash-set + val + pos-interpose + (λ (val ele) (late-neg-neg-proj ele neg-party)) + pos-interpose + impersonator-prop:contracted + ctc)]))) + (cond + [lazy? set/c-lazy-late-neg-proj] + [else + (λ (val neg-party) + (set-contract-check cmp kind blame neg-party val) + (define w/chaperone + (cond + [(set? val) val] + [else + (chaperone-hash-set + val + (λ (val ele) ele) + (λ (val ele) (late-neg-neg-proj ele neg-party)) + (λ (val ele) ele))])) + (chaperone-hash-set + (for/set ([ele (in-set w/chaperone)]) + (late-neg-pos-proj ele neg-party)) + (chaperone-hash-set + val + #f #f #f + impersonator-prop:contracted + ctc)))]))) + + +(define (generic-set-late-neg-projection ctc chaperone-ctc?) + (define elem/c (set-contract-elem/c ctc)) + (define cmp (set-contract-cmp ctc)) + (define kind (set-contract-kind ctc)) + (define lazy? (set-contract-lazy? ctc)) + (lambda (blame) + (define (method sym c) + (define name (contract-name c)) + (define str (format "method ~a with contract ~.s" sym name)) + (define b2 (blame-add-context blame str)) + ((contract-late-neg-projection c) b2)) + (define-syntax (redirect stx) + (syntax-case stx () + [(_ [id expr] ...) + (with-syntax ([(proj-id ...) (generate-temporaries #'(id ...))]) + #'(let ([proj-id (method 'id expr)] ...) + (λ (x neg-party) + (redirect-generics chaperone-ctc? + gen:set x [id (λ (x) (proj-id x neg-party))] ...))))])) + (define me (if chaperone-contract? + (make-chaperone-contract + #:name (set-contract-name ctc) + #:stronger set-contract-stronger + #:late-neg-projection + (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))) + (make-contract + #:name (set-contract-name ctc) + #:stronger set-contract-stronger + #:late-neg-projection + (λ (blame) (λ (val neg-party) (do-redirect val neg-party)))))) + (define do-redirect + (redirect + [set-member? (-> generic-set? elem/c boolean?)] + [set-empty? (or/c (-> generic-set? boolean?) #f)] + [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)] + [set=? (or/c (-> generic-set? me boolean?) #f)] + [subset? (or/c (-> generic-set? me boolean?) #f)] + [proper-subset? (or/c (-> generic-set? me boolean?) #f)] + [set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #f)] + [set-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)] + [set-copy (or/c (-> generic-set? generic-set?) #f)] + [in-set (or/c (-> generic-set? sequence?) #f)] + [set->list (or/c (-> generic-set? (listof elem/c)) #f)] + [set->stream (or/c (-> generic-set? stream?) #f)] + [set-first (or/c (-> generic-set? elem/c) #f)] + [set-rest (or/c (-> generic-set? me) #f)] + [set-add (or/c (-> generic-set? elem/c me) #f)] + [set-remove (or/c (-> generic-set? elem/c me) #f)] + [set-clear (or/c (-> generic-set? me) #f)] + [set-copy-clear (or/c (-> generic-set? generic-set?) #f)] + [set-union + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-intersect + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-subtract + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-symmetric-difference + (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)] + [set-add! (or/c (-> generic-set? elem/c void?) #f)] + [set-remove! (or/c (-> generic-set? elem/c void?) #f)] + [set-clear! (or/c (-> generic-set? void?) #f)] + [set-union! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] + [set-intersect! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] + [set-subtract! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)] + [set-symmetric-difference! + (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)])) + (define proj + ((contract-late-neg-projection elem/c) (blame-add-element-context blame #f))) + (lambda (x neg-party) + (set-contract-check cmp kind blame neg-party x) + (cond + [(list? x) + (for/list ([e (in-list x)]) + (proj e neg-party))] + [else + (do-redirect x neg-party)])))) + + +(define (blame-add-element-context blame swap?) + (blame-add-context blame "an element of" #:swap? swap?)) (define (flat-set-contract-first-order ctc) (define set-passes? (set-contract-first-order ctc)) @@ -206,10 +286,9 @@ (define elem/c (set-contract-elem/c ctc)) (define cmp (set-contract-cmp ctc)) (define kind (set-contract-kind ctc)) + (define mk-elem/c-proj (contract-late-neg-projection elem/c)) (lambda (b) - (define proj - ((contract-late-neg-projection elem/c) - (blame-add-context b "an element of"))) + (define proj (mk-elem/c-proj (blame-add-context b "an element of"))) (lambda (x neg-party) (set-contract-check cmp kind b neg-party x) (for ([e (in-set x)])