suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust set/c to follow the late-neg protocol

Browse Source 
and make it do some work earlier
This commit is contained in:
Robby Findler 2015-12-19 21:51:40 -06:00
parent 53fa16fc9c
commit 15e24fce78
1 changed files with 98 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
racket/collects/racket/set.rkt
View File

@ -5,7 +5,8 @@
racket/private/set racket/private/set
racket/private/set-types racket/private/set-types
racket/generic racket/generic
racket/private/for) racket/private/for
(for-syntax racket/base))
(provide (all-from-out racket/private/set) (provide (all-from-out racket/private/set)
(all-from-out racket/private/set-types) (all-from-out racket/private/set-types)
@ -86,63 +87,71 @@
(lambda (x) (lambda (x)
(and (generic-set? x) (cmp? x) (kind? x)))) (and (generic-set? x) (cmp? x) (kind? x))))
(define (set-contract-check cmp kind b x) (define (set-contract-check cmp kind b neg-party x)
(unless (generic-set? x) (unless (generic-set? x)
(raise-blame-error b x "expected a set")) (raise-blame-error b #:missing-party neg-party x "expected a set"))
(case cmp (case cmp
[(equal) [(equal)
(unless (set-equal? x) (unless (set-equal? x)
(raise-blame-error b x "expected an equal?-based set"))] (raise-blame-error b #:missing-party neg-party x "expected an equal?-based set"))]
[(eqv) [(eqv)
(unless (set-eqv? x) (unless (set-eqv? x)
(raise-blame-error b x "expected an eqv?-based set"))] (raise-blame-error b #:missing-party neg-party x "expected an eqv?-based set"))]
[(eq) [(eq)
(unless (set-eq? x) (unless (set-eq? x)
(raise-blame-error b x "expected an eq?-based set"))]) (raise-blame-error b #:missing-party neg-party x "expected an eq?-based set"))])
(case kind (case kind
[(mutable-or-weak) [(mutable-or-weak)
(unless (or (set-mutable? x) (set-weak? x)) (unless (or (set-mutable? x) (set-weak? x))
(raise-blame-error b x "expected a mutable or weak set"))] (raise-blame-error b #:missing-party neg-party x "expected a mutable or weak set"))]
[(mutable) [(mutable)
(unless (set-mutable? x) (unless (set-mutable? x)
(raise-blame-error b x "expected a mutable set"))] (raise-blame-error b #:missing-party neg-party x "expected a mutable set"))]
[(weak) [(weak)
(unless (set-weak? x) (unless (set-weak? x)
(raise-blame-error b x "expected a weak set"))] (raise-blame-error b #:missing-party neg-party x "expected a weak set"))]
[(immutable) [(immutable)
(unless (set? x) (unless (set? x)
(raise-blame-error b x "expected an immutable set"))])) (raise-blame-error b #:missing-party neg-party x "expected an immutable set"))]))
(define (set-contract-projection mode) (define (set-contract-late-neg-projection chaperone-ctc?)
(lambda (ctc) (lambda (ctc)
(define elem/c (set-contract-elem/c ctc)) (define elem/c (set-contract-elem/c ctc))
(define cmp (set-contract-cmp ctc)) (define cmp (set-contract-cmp ctc))
(define kind (set-contract-kind ctc)) (define kind (set-contract-kind ctc))
(lambda (b) (lambda (blame)
(lambda (x)
(set-contract-check cmp kind b x)
(cond
[(list? x)
(define proj
((contract-projection elem/c)
(blame-add-context b "an element of")))
(map proj x)]
[else
(define (method sym c) (define (method sym c)
(lambda (x)
(define name (contract-name c)) (define name (contract-name c))
(define str (format "method ~a with contract ~.s" sym name)) (define str (format "method ~a with contract ~.s" sym name))
(define b2 (blame-add-context b str)) (define b2 (blame-add-context blame str))
(((contract-projection c) b2) x))) ((contract-late-neg-projection c) b2))
(define-syntax-rule (redirect [id expr] ...) (define-syntax (redirect stx)
(redirect-generics mode gen:set x [id (method 'id expr)] ...)) (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 (redirect
[set-member? (-> generic-set? elem/c boolean?)] [set-member? (-> generic-set? elem/c boolean?)]
[set-empty? (or/c (-> generic-set? boolean?) #f)] [set-empty? (or/c (-> generic-set? boolean?) #f)]
[set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)] [set-count (or/c (-> generic-set? exact-nonnegative-integer?) #f)]
[set=? (or/c (-> generic-set? ctc boolean?) #f)] [set=? (or/c (-> generic-set? me boolean?) #f)]
[subset? (or/c (-> generic-set? ctc boolean?) #f)] [subset? (or/c (-> generic-set? me boolean?) #f)]
[proper-subset? (or/c (-> generic-set? ctc boolean?) #f)] [proper-subset? (or/c (-> generic-set? me boolean?) #f)]
[set-map (or/c (-> generic-set? (-> elem/c any/c) list?) #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-for-each (or/c (-> generic-set? (-> elem/c any) void?) #f)]
[set-copy (or/c (-> generic-set? generic-set?) #f)] [set-copy (or/c (-> generic-set? generic-set?) #f)]
@ -150,30 +159,40 @@
[set->list (or/c (-> generic-set? (listof elem/c)) #f)] [set->list (or/c (-> generic-set? (listof elem/c)) #f)]
[set->stream (or/c (-> generic-set? stream?) #f)] [set->stream (or/c (-> generic-set? stream?) #f)]
[set-first (or/c (-> generic-set? elem/c) #f)] [set-first (or/c (-> generic-set? elem/c) #f)]
[set-rest (or/c (-> generic-set? ctc) #f)] [set-rest (or/c (-> generic-set? me) #f)]
[set-add (or/c (-> generic-set? elem/c ctc) #f)] [set-add (or/c (-> generic-set? elem/c me) #f)]
[set-remove (or/c (-> generic-set? elem/c ctc) #f)] [set-remove (or/c (-> generic-set? elem/c me) #f)]
[set-clear (or/c (-> generic-set? ctc) #f)] [set-clear (or/c (-> generic-set? me) #f)]
[set-copy-clear (or/c (-> generic-set? generic-set?) #f)] [set-copy-clear (or/c (-> generic-set? generic-set?) #f)]
[set-union [set-union
(or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
[set-intersect [set-intersect
(or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
[set-subtract [set-subtract
(or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
[set-symmetric-difference [set-symmetric-difference
(or/c (->* [generic-set?] [] #:rest (listof ctc) ctc) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) me) #f)]
[set-add! (or/c (-> generic-set? elem/c void?) #f)] [set-add! (or/c (-> generic-set? elem/c void?) #f)]
[set-remove! (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-clear! (or/c (-> generic-set? void?) #f)]
[set-union! [set-union!
(or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
[set-intersect! [set-intersect!
(or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
[set-subtract! [set-subtract!
(or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)] (or/c (->* [generic-set?] [] #:rest (listof me) void?) #f)]
[set-symmetric-difference! [set-symmetric-difference!
(or/c (->* [generic-set?] [] #:rest (listof ctc) void?) #f)])]))))) (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
[(list? x)
(map proj x)]
[else
(do-redirect x neg-party)])))))
(define (flat-set-contract-first-order ctc) (define (flat-set-contract-first-order ctc)
(define set-passes? (set-contract-first-order ctc)) (define set-passes? (set-contract-first-order ctc))
@ -183,37 +202,43 @@
(for/and ([e (in-set x)]) (for/and ([e (in-set x)])
(elem-passes? e))))) (elem-passes? e)))))
(define (flat-set-contract-projection ctc) (define (flat-set-contract-late-neg-projection ctc)
(define elem/c (set-contract-elem/c ctc)) (define elem/c (set-contract-elem/c ctc))
(define cmp (set-contract-cmp ctc)) (define cmp (set-contract-cmp ctc))
(define kind (set-contract-kind ctc)) (define kind (set-contract-kind ctc))
(lambda (b) (lambda (b)
(lambda (x)
(set-contract-check cmp kind b x)
(define proj (define proj
((contract-projection elem/c) ((contract-late-neg-projection elem/c)
(blame-add-context b "an element of"))) (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)]) (for ([e (in-set x)])
(proj e)) (proj e neg-party))
x))) x)))
(define (set-contract-stronger this that)
#f)
(struct flat-set-contract set-contract [] (struct flat-set-contract set-contract []
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:name set-contract-name #:name set-contract-name
#:stronger set-contract-stronger
#:first-order flat-set-contract-first-order #:first-order flat-set-contract-first-order
#:projection flat-set-contract-projection)) #:late-neg-projection flat-set-contract-late-neg-projection))
(struct chaperone-set-contract set-contract [] (struct chaperone-set-contract set-contract []
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:name set-contract-name #:name set-contract-name
#:stronger set-contract-stronger
#:first-order set-contract-first-order #:first-order set-contract-first-order
#:projection (set-contract-projection #t))) #:late-neg-projection (set-contract-late-neg-projection #t)))
(struct impersonator-set-contract set-contract [] (struct impersonator-set-contract set-contract []
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name set-contract-name #:name set-contract-name
#:stronger set-contract-stronger
#:first-order set-contract-first-order #:first-order set-contract-first-order
#:projection (set-contract-projection #f))) #:late-neg-projection (set-contract-late-neg-projection #f)))