Fix set/c to conform to hash/c-like restrictions.
Since sets are implemented using the elements as the domain of a hash table, the following must be true: * element contracts for (seteq ...) must be flat * element contracts for (seteqv ...) must be flat * element contracts for (set ...) must be chaperones, and the resulting contract is a chaperone contract Also, change higher-order set/c contracts to be chaperone contracts due to the new restrictions.
This commit is contained in:
Stevie Strickland
parent
19ce4d44a5
commit
01396784c9
|
|
@ -85,6 +85,28 @@
|
|||
(lambda (set hc) (add1 (hc (set-ht set)))))
|
||||
#:property prop:sequence (lambda (v) (*in-set v)))
|
||||
|
||||
;; Not currently exporting this because I'm not sure whether this is the right semantics
|
||||
;; for it yet, but it follows most closely the semantics of the old set/c implementation
|
||||
;; (while still returning a chaperone).
|
||||
(define (chaperone-set s elem-chaperone)
|
||||
(when (or (set-eq? s)
|
||||
(set-eqv? s))
|
||||
(raise-type-error 'chaperone-set "equal-based set" s))
|
||||
(chaperone-struct s
|
||||
set-ht
|
||||
(let ([cached-ht #f])
|
||||
(λ (st ht)
|
||||
(if cached-ht cached-ht
|
||||
(let ([new-ht (make-immutable-hash
|
||||
(hash-map ht (λ (k v)
|
||||
;; should be a check of the return here,
|
||||
;; but until this is exported, it's only
|
||||
;; used by set/c, which is sure to pass
|
||||
;; a chaperone-respecting function.
|
||||
(cons (elem-chaperone s k) v))))])
|
||||
(set! cached-ht new-ht)
|
||||
new-ht))))))
|
||||
|
||||
(define (set . elems)
|
||||
(make-set (make-immutable-hash (map (lambda (k) (cons k #t)) elems))))
|
||||
(define (seteq . elems)
|
||||
|
|
@ -328,9 +350,19 @@
|
|||
(raise-type-error 'set/c
|
||||
"(or/c 'dont-care 'equal? 'eq? 'eqv)"
|
||||
cmp))
|
||||
(if (flat-contract? ctc)
|
||||
(flat-set/c ctc cmp (flat-contract-predicate ctc))
|
||||
(make-set/c ctc cmp)))
|
||||
(cond
|
||||
[(flat-contract? ctc)
|
||||
(flat-set/c ctc cmp (flat-contract-predicate ctc))]
|
||||
[(chaperone-contract? ctc)
|
||||
(if (memq cmp '(eq eqv))
|
||||
(raise-type-error 'set/c
|
||||
"flat contract"
|
||||
ctc)
|
||||
(make-set/c ctc cmp))]
|
||||
[else
|
||||
(raise-type-error 'set/c
|
||||
"chaperone contract"
|
||||
ctc)]))
|
||||
set/c))
|
||||
|
||||
(define (set/c-name c)
|
||||
|
|
@ -347,45 +379,51 @@
|
|||
(contract-stronger? (set/c-ctc this)
|
||||
(set/c-ctc that))))
|
||||
|
||||
(define (check-set/c ctc)
|
||||
(let ([elem-ctc (set/c-ctc ctc)]
|
||||
[pred (get-pred ctc)]
|
||||
[name (get-name ctc)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (pred val)
|
||||
(fail "expected a <~a>, got ~a" name val))
|
||||
(when first-order?
|
||||
(for ([e (in-set val)])
|
||||
(unless (contract-first-order-passes? elem-ctc e)
|
||||
(fail "expected: ~s, got ~v" (contract-name elem-ctc) e))))
|
||||
#t)))
|
||||
|
||||
(define (set/c-first-order ctc)
|
||||
(let ([check (check-set/c ctc)])
|
||||
(λ (val)
|
||||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
|
||||
(define (set/c-proj c)
|
||||
(let ([proj (contract-projection (set/c-ctc c))]
|
||||
[pred (get-pred c)])
|
||||
[check (check-set/c c)])
|
||||
(λ (blame)
|
||||
(let ([pb (proj blame)])
|
||||
(λ (s)
|
||||
(if (pred s)
|
||||
(cond
|
||||
[(set-equal? s)
|
||||
(for/set ((e (in-set s)))
|
||||
(pb e))]
|
||||
[(set-eqv? s)
|
||||
(for/seteqv ((e (in-set s)))
|
||||
(pb e))]
|
||||
[(set-eq? s)
|
||||
(for/seteq ((e (in-set s)))
|
||||
(pb e))])
|
||||
(raise-blame-error
|
||||
blame
|
||||
s
|
||||
"expected a <~a>, got ~v"
|
||||
(get-name c)
|
||||
s)))))))
|
||||
(check s (λ args (apply raise-blame-error blame s args)))
|
||||
(chaperone-set s (λ (s v) (pb v))))))))
|
||||
|
||||
(define-struct set/c (ctc cmp)
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name set/c-name
|
||||
#:first-order get-pred
|
||||
#:first-order set/c-first-order
|
||||
#:stronger set/c-stronger
|
||||
#:projection set/c-proj))
|
||||
|
||||
(define (flat-first-order c)
|
||||
(let ([inner-pred (flat-set/c-pred c)]
|
||||
[pred (get-pred c)])
|
||||
(λ (s)
|
||||
(and (pred s)
|
||||
(for/and ((e (in-set s)))
|
||||
(inner-pred e))))))
|
||||
(define (flat-set/c-proj c)
|
||||
(let ([proj (contract-projection (set/c-ctc c))]
|
||||
[check (check-set/c c)])
|
||||
(λ (blame)
|
||||
(let ([pb (proj blame)])
|
||||
(λ (val)
|
||||
(check val (λ args (apply raise-blame-error blame val args)))
|
||||
(for ([e (in-set val)]) (pb e))
|
||||
val)))))
|
||||
|
||||
(define-values (flat-set/c flat-set/c-pred)
|
||||
(let ()
|
||||
|
|
@ -393,9 +431,9 @@
|
|||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name set/c-name
|
||||
#:first-order flat-first-order
|
||||
#:first-order set/c-first-order
|
||||
#:stronger set/c-stronger
|
||||
#:projection set/c-proj))
|
||||
#:projection flat-set/c-proj))
|
||||
(values make-flat-set/c flat-set/c-pred)))
|
||||
|
||||
;; ----
|
||||
|
|
|
|||
|
|
@ -207,12 +207,16 @@ Returns @racket[#t] if @racket[st] compares elements with @racket[eqv?],
|
|||
Returns @racket[#t] if @racket[st] compares elements with @racket[eq?],
|
||||
@racket[#f] if it compares with @racket[equal?] or @racket[eqv?].}
|
||||
|
||||
@defproc[(set/c [contract contract?] [#:cmp cmp (or/c 'dont-care 'equal 'eqv 'eq) 'dont-care]) contract?]{
|
||||
@defproc[(set/c [contract chaperone-contract?] [#:cmp cmp (or/c 'dont-care 'equal 'eqv 'eq) 'dont-care]) contract?]{
|
||||
Constructs a contract that recognizes sets whose elements match @racket[contract].
|
||||
|
||||
If @racket[cmp] is @racket['dont-care], then the equality notion of the set is not considered
|
||||
when checking the contract. Otherwise, the contract accepts only sets with the corresponding
|
||||
notion of equality.
|
||||
|
||||
If @racket[cmp] is @racket['eq] or @racket['eqv], then @racket[contract] must be a flat contract.
|
||||
If @racket[contract] is not a flat contract, then @racket[cmp] cannot be @racket['eq] or @racket['eqv]
|
||||
and the resulting contract can only be applied to sets that use @racket[equal?] for equality.
|
||||
}
|
||||
|
||||
@defproc[(in-set [st set?]) sequence?]{
|
||||
|
|
|
|||
|
|
@ -9385,6 +9385,19 @@ so that propagation occurs.
|
|||
(struct/c s alpha)))
|
||||
|
||||
(ctest #t flat-contract? (set/c integer?))
|
||||
(ctest #f flat-contract? (set/c (-> integer? integer?)))
|
||||
(ctest #t chaperone-contract? (set/c (-> integer? integer?)))
|
||||
|
||||
;; Make sure that impersonators cannot be used as the element contract in set/c.
|
||||
(contract-error-test
|
||||
'contract-error-test-set
|
||||
'(let ([proxy-ctc
|
||||
(make-contract
|
||||
#:name 'proxy-ctc
|
||||
#:first-order values
|
||||
#:projection (λ (b) values))])
|
||||
(set/c proxy-ctc))
|
||||
exn:fail?)
|
||||
|
||||
;; Hash contracts with flat domain/range contracts
|
||||
(ctest #t contract? (hash/c any/c any/c #:immutable #f))
|
||||
|
|
@ -9941,7 +9954,7 @@ so that propagation occurs.
|
|||
(test-name '(set/c boolean? #:cmp 'equal) (set/c boolean? #:cmp 'equal))
|
||||
(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 'eqv) (set/c (-> char? char?) #:cmp 'eqv))
|
||||
(test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal))
|
||||
|
||||
;; NOT YET RELEASED
|
||||
#;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user