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

Added tools for contracts, impersonators, and chaperones for generic interfaces.

Browse Source 
Added four macros to racket/generic:
- chaperone-generics
- impersonate-generics
- redirect-generics (dynamically chooses between the above two)
- generic-instance/c
All take pairs of method names and wrappers (procedures or contracts),
and turn those into appropriate chaperone, impersonator, or contract wrappers
on the method tables of the given structs.

Used this to rewrite set/c to give better error messages.
This commit is contained in:
Carl Eastlund 2013-07-24 17:06:29 -04:00
parent 6b337efd2f
commit 2f473c2403
9 changed files with 387 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

268
racket/collects/racket/generic.rkt
View File

@ -2,6 +2,7 @@
(require racket/contract/base
racket/contract/combinator
"private/generic.rkt"
"private/generic-methods.rkt"
(for-syntax racket/base racket/local racket/syntax syntax/stx))
;; Convenience layer on top of racket/private/generic.
@ -11,7 +12,12 @@
;; Files that use racket/private/generic _must_ pass _all_ keyword
;; arguments to define-generics _in_order_.
(provide define-generics define/generic)
(provide define-generics
define/generic
chaperone-generics
impersonate-generics
redirect-generics
generic-instance/c)
(begin-for-syntax
@ -144,6 +150,7 @@
index))
(define/with-syntax pred-name (format-id #'name "~a?" #'name))
(define/with-syntax gen-name (format-id #'name "gen:~a" #'name))
(define/with-syntax ctc-name (format-id #'name "~a/c" #'name))
(define/with-syntax prop-name (generate-temporary #'name))
(define/with-syntax get-name (generate-temporary #'name))
(define/with-syntax support-name support)
@ -166,134 +173,159 @@
#:derive-properties [derive ...]
method ...)
table-defn
(define-generics-contract name pred-name get-name
[method-name method-index]
...)))]))
(define-generics-contract ctc-name gen-name)))]))
;; generate a contract combinator for instances of a generic interface
(define-syntax (define-generics-contract stx)
(define-syntax (redirect-generics/derived stx)
(syntax-case stx ()
[(_ name name? accessor (generic generic-idx) ...)
(with-syntax ([name/c (format-id #'name "~a/c" #'name)])
#`(define-syntax (name/c stx)
(syntax-case stx ()
[(_ [method-id ctc] (... ...))
(andmap (λ (id) (and (identifier? id)
;; make sure the ids are all
;; in the interface
(member (syntax-e id) (list 'generic ...))))
(syntax->list #'(method-id (... ...))))
#'(make-generic-instance/c
(quote #,(syntax-e #'name/c))
name?
accessor
(list 'method-id (... ...))
(list ctc (... ...))
(make-immutable-hash
(list (cons 'generic generic-idx) ...)))])))]))
[(_ orig mode gen-name val-expr [method-name proc-expr] ...)
(parameterize ([current-syntax-context #'orig])
(define gen-id #'gen-name)
(unless (identifier? gen-id)
(wrong-syntax gen-id "expected an identifier"))
(define gen-info (syntax-local-value gen-id (lambda () #f)))
(unless (generic-info? gen-info)
(wrong-syntax gen-id "expected a name for a generic interface"))
(define delta (syntax-local-make-delta-introducer gen-id))
(define predicate (generic-info-predicate gen-info))
(define accessor (generic-info-accessor gen-info))
(define method-ids (syntax->list #'(method-name ...)))
(define indices
(for/list ([method-id (in-list method-ids)])
(find-generic-method-index #'orig gen-id delta gen-info method-id)))
(define/with-syntax pred-name predicate)
(define/with-syntax ref-name accessor)
(define/with-syntax [method-index ...] indices)
#'(redirect-generics-proc 'gen-name mode pred-name ref-name val-expr
(lambda (i x)
(case i
[(method-index) (proc-expr x)]
...
[else x]))))]))
;; make a generic instance contract
(define (make-generic-instance/c name name? accessor ids ctc-args method-map)
(define ctcs (coerce-contracts 'generic-instance/c ctc-args))
;; map method table indices to ids & projections
(define id+ctc-map
(for/hash ([id ids] [ctc ctcs])
(values (hash-ref method-map id)
(cons id (contract-projection ctc)))))
(cond [(andmap chaperone-contract? ctcs)
(chaperone-generic-instance/c
name name? ids ctcs accessor id+ctc-map method-map)]
[else
(impersonator-generic-instance/c
name name? ids ctcs accessor id+ctc-map method-map)]))
(define-syntax (redirect-generics stx)
(syntax-case stx ()
[(_ mode gen-name val-expr [id expr] ...)
#`(redirect-generics/derived #,stx mode gen-name val-expr [id expr] ...)]))
(define (generic-instance/c-name ctc)
(define method-names
(map (λ (id ctc) (build-compound-type-name id ctc))
(base-generic-instance/c-ids ctc)
(base-generic-instance/c-ctcs ctc)))
(apply build-compound-type-name
(cons (base-generic-instance/c-name ctc) method-names)))
(define-syntax (chaperone-generics stx)
(syntax-case stx ()
[(_ gen-name val-expr [id expr] ...)
#`(redirect-generics/derived #,stx #t gen-name val-expr [id expr] ...)]))
;; redirect for use with chaperone-vector
(define ((method-table-redirect ctc blame) vec idx val)
(define id+ctc-map (base-generic-instance/c-id+ctc-map ctc))
(define maybe-id+ctc (hash-ref id+ctc-map idx #f))
(cond [maybe-id+ctc
(define id (car maybe-id+ctc))
(define proj (cdr maybe-id+ctc))
(define blame-string (format "the ~a method of" id))
((proj (blame-add-context blame blame-string)) val)]
[else val]))
(define-syntax (impersonate-generics stx)
(syntax-case stx ()
[(_ gen-name val-expr [id expr] ...)
#`(redirect-generics/derived #,stx #f gen-name val-expr [id expr] ...)]))
;; projection for generic methods
(define ((generic-instance/c-proj proxy-struct proxy-vector) ctc)
(λ (blame)
;; for redirecting the method table accessor
(define (redirect struct v)
(proxy-vector
v
(method-table-redirect ctc blame)
(λ (vec i v) v)))
(λ (val)
(unless ((base-generic-instance/c-name? ctc) val)
(raise-blame-error
blame val
'(expected: "~s" given: "~e")
(contract-name ctc)
val))
(define accessor (base-generic-instance/c-accessor ctc))
(define method-table (accessor val))
(define ids (base-generic-instance/c-ids ctc))
(define ctcs (base-generic-instance/c-ctcs ctc))
(define method-map (base-generic-instance/c-method-map ctc))
;; do sub-contract first-order checks
(for ([id ids] [ctc ctcs])
(define v (vector-ref method-table (hash-ref method-map id)))
(unless (contract-first-order-passes? ctc v)
(raise-blame-error
(blame-add-context blame (format "method ~s of" id))
v
'(expected: "~s" given: "~e")
(contract-name ctc)
v)))
(proxy-struct val accessor redirect))))
(define (redirect-generics-proc name chaperoning? pred ref x proc)
(unless (pred x)
(raise-argument-error name (format "a structure implementing ~a" name) x))
(define-values (redirect-struct redirect-vector)
(if chaperoning?
(values chaperone-struct chaperone-vector)
(values impersonate-struct impersonate-vector)))
(define (vec-proc vec i method)
(proc i method))
(define (struct-proc x vec)
(redirect-vector vec vec-proc vec-proc))
(redirect-struct x ref struct-proc))
;; recognizes instances of this generic interface
(define ((generic-instance/c-first-order ctc) v)
(cond [((base-generic-instance/c-name? ctc) v)
(define accessor (base-generic-instance/c-accessor ctc))
(define method-table (accessor v))
(define ids (base-generic-instance/c-ids ctc))
(define ctcs (base-generic-instance/c-ctcs ctc))
(define method-map (base-generic-instance/c-method-map ctc))
;; do sub-contract first-order checks
(for/and ([id ids] [ctc ctcs])
(contract-first-order-passes?
ctc
(vector-ref method-table (hash-ref method-map id))))]
[else #f]))
(define-syntax-rule (define-generics-contract ctc-name gen-name)
(define-syntax (ctc-name stx)
(syntax-case stx ()
[(_ [id expr] (... ...))
#`(generic-instance/c/derived #,stx
[ctc-name]
gen-name
[id expr]
(... ...))])))
;; name - for building ctc name
;; name? - for first-order checks
;; ids - for method names (used to build the ctc name)
;; ctcs - for the contract name
;; accessor - for chaperoning the struct type property
;; id+ctc-map - for chaperoning the method table vector
;; method-map - for first-order checks
(struct base-generic-instance/c
(name name? ids ctcs accessor id+ctc-map method-map))
(define-syntax (generic-instance/c stx)
(syntax-case stx ()
[(_ gen-name [id expr] ...)
#`(generic-instance/c/derived #,stx
[generic-instance/c gen-name]
gen-name
[id expr]
...)]))
(struct chaperone-generic-instance/c base-generic-instance/c ()
(define-syntax (generic-instance/c/derived stx)
(syntax-case stx ()
[(_ original [prefix ...] gen-name [method-id ctc-expr] ...)
(parameterize ([current-syntax-context #'original])
(define gen-id #'gen-name)
(unless (identifier? gen-id)
(wrong-syntax gen-id "expected an identifier"))
(define gen-info (syntax-local-value gen-id (lambda () #f)))
(unless (generic-info? gen-info)
(wrong-syntax gen-id "expected a name for a generic interface"))
(define predicate (generic-info-predicate gen-info))
(define/with-syntax pred predicate)
(define/with-syntax [ctc-id ...]
(generate-temporaries #'(ctc-expr ...)))
(define/with-syntax [proj-id ...]
(generate-temporaries #'(ctc-expr ...)))
#'(let* ([ctc-id ctc-expr] ...)
(make-generics-contract
'gen-name
'[prefix ...]
pred
'(method-id ...)
(list ctc-id ...)
(lambda (b x mode)
(redirect-generics
mode
gen-name
x
[method-id
(lambda (m)
(define b2
(blame-add-context b (format "method ~a" 'method-id)))
(((contract-projection ctc-id) b2) m))]
...)))))]))
(define (make-generics-contract ifc pfx pred mths ctcs proc)
(define chaperoning?
(for/and ([mth (in-list mths)] [ctc (in-list ctcs)])
(unless (contract? ctc)
(raise-arguments-error
(car pfx)
"non-contract value supplied for method"
"value" ctc
"method" mth
"generic interface" ifc))
(chaperone-contract? ctc)))
(if chaperoning?
(chaperone-generics-contract pfx pred mths ctcs proc)
(impersonator-generics-contract pfx pred mths ctcs proc)))
(struct generics-contract [prefix predicate methods contracts redirect])
(define (generics-contract-name ctc)
`(,@(generics-contract-prefix ctc)
,@(for/list ([method (in-list (generics-contract-methods ctc))]
[c (in-list (generics-contract-contracts ctc))])
(list method (contract-name c)))))
(define (generics-contract-first-order ctc)
(generics-contract-predicate ctc))
(define (generics-contract-projection mode)
(lambda (c)
(lambda (b)
(lambda (x)
((generics-contract-redirect c) b x mode)))))
(struct chaperone-generics-contract generics-contract []
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (generic-instance/c-proj chaperone-struct chaperone-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))
#:name generics-contract-name
#:first-order generics-contract-first-order
#:projection (generics-contract-projection #t)))
(struct impersonator-generic-instance/c base-generic-instance/c ()
(struct impersonator-generics-contract generics-contract []
#:property prop:contract
(build-contract-property
#:projection (generic-instance/c-proj impersonate-struct impersonate-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))
#:name generics-contract-name
#:first-order generics-contract-first-order
#:projection (generics-contract-projection #f)))

2
racket/collects/racket/private/for.rkt
View File

@ -68,7 +68,7 @@
stream-first
stream-rest
prop:stream
stream-ref ; only provided for racket/stream
stream-ref stream-via-prop? ; only provided for racket/stream
sequence->stream
empty-stream make-do-stream

4
racket/collects/racket/private/generic-interfaces.rkt
View File

@ -38,6 +38,8 @@
(define-syntax gen:equal+hash
(make-generic-info (quote-syntax prop:gen:equal+hash)
(quote-syntax equal+hash?)
(quote-syntax gen:equal+hash-acc)
(list (quote-syntax equal-proc)
(quote-syntax hash-proc)
(quote-syntax hash2-proc))))
@ -67,6 +69,8 @@
(define-syntax gen:custom-write
(make-generic-info (quote-syntax prop:gen:custom-write)
(quote-syntax gen:custom-write?)
(quote-syntax gen:custom-write-acc)
(list (quote-syntax write-proc))))
)

115
racket/collects/racket/private/generic-methods.rkt
View File

@ -11,7 +11,10 @@
(for-syntax generic-info?
make-generic-info
generic-info-property
generic-info-methods))
generic-info-predicate
generic-info-accessor
generic-info-methods
find-generic-method-index))
(begin-for-syntax
@ -20,12 +23,16 @@
generic-info?
generic-info-get
generic-info-set!)
(make-struct-type 'generic-info #f 2 0))
(make-struct-type 'generic-info #f 4 0))
(define-values (generic-info-property
generic-info-predicate
generic-info-accessor
generic-info-methods)
(values (make-struct-field-accessor generic-info-get 0 'property)
(make-struct-field-accessor generic-info-get 1 'methods)))
(make-struct-field-accessor generic-info-get 1 'predicate)
(make-struct-field-accessor generic-info-get 2 'accessor)
(make-struct-field-accessor generic-info-get 3 'methods)))
(define (check-identifier! name ctx stx)
(unless (identifier? stx)
@ -56,7 +63,80 @@
unimplemented-transformer))))
(define unimplemented-method
(make-struct-field-accessor unimplemented-get 0 'method)))
(make-struct-field-accessor unimplemented-get 0 'method))
(define (find-generic-method who ctx gen-id delta gen-info method-id proc)
(unless (syntax? ctx)
(raise-argument-error who "syntax?" ctx))
(unless (identifier? gen-id)
(raise-argument-error who "identifier?" gen-id))
(unless (and (procedure? delta)
(procedure-arity-includes? delta 1))
(raise-argument-error who "(syntax? . -> . syntax?)" delta))
(unless (generic-info? gen-info)
(raise-argument-error who "generic-info?" gen-info))
(unless (identifier? method-id)
(raise-argument-error who "identifier?" method-id))
(unless (and (procedure? proc)
(procedure-arity-includes? proc 2))
(raise-argument-error
who
"(exact-nonnegative-integer? identifier? . -> . any)"
proc))
(define-values (originals indices)
(let loop ([original-ids (generic-info-methods gen-info)]
[index 0]
[rev-originals '()]
[rev-indices '()])
(cond
[(null? original-ids)
(values (reverse rev-originals)
(reverse rev-indices))]
[else
(define original-id (car original-ids))
(define context-id (syntax-local-get-shadower (delta original-id)))
(cond
[(free-identifier=? context-id method-id)
(loop (cdr original-ids)
(add1 index)
(cons original-id rev-originals)
(cons index rev-indices))]
[else
(loop (cdr original-ids)
(add1 index)
rev-originals
rev-indices)])])))
(when (null? originals)
(raise-syntax-error
#f
(format "~.s is not a method of generic interfaces ~.s"
(syntax-e method-id)
(syntax-e gen-id))
ctx
method-id))
(unless (null? (cdr originals))
(raise-syntax-error
#f
(format "multiple methods match ~.s in generic interface ~.s: ~.s"
(syntax-e method-id)
(syntax-e gen-id)
(map syntax-e originals))
ctx
method-id))
(proc (car indices) (car originals)))
(define (find-generic-method-index ctx gen-id delta gen-info method-id)
(find-generic-method 'find-generic-method-index
ctx gen-id delta gen-info method-id
(lambda (index original) index)))
(define (find-generic-method-original ctx gen-id delta gen-info method-id)
(find-generic-method 'find-generic-method-index
ctx gen-id delta gen-info method-id
(lambda (index original) original))))
(define-syntax-parameter generic-method-context #f)
@ -110,28 +190,7 @@
(raise-syntax-error 'define/generic "expected an identifier" #'ref))
(define delta (syntax-local-make-delta-introducer gen-id))
(define methods (generic-info-methods gen-val))
(define matches
(let loop ([methods methods])
(cond
[(null? methods) '()]
[(free-identifier=? (syntax-local-get-shadower
(delta (car methods)))
#'ref)
(cons (car methods) (loop (cdr methods)))]
[else (loop (cdr methods))])))
(unless (pair? matches)
(raise-syntax-error 'define/generic
(format "~.s is not a method of ~.s"
(syntax-e #'ref)
(syntax-e gen-id))
stx
#'ref))
(when (pair? (cdr matches))
(raise-syntax-error 'define/generic
(format "multiple methods match ~.s: ~.s"
(syntax-e #'ref)
(map syntax-e matches))
stx
#'ref))
(with-syntax ([method (car matches)])
(define method-id
(find-generic-method-original stx gen-id delta gen-val #'ref))
(with-syntax ([method method-id])
#'(define bind method)))])))

2
racket/collects/racket/private/generic.rkt
View File

@ -95,6 +95,8 @@
#'(begin
(define-syntax generic-name
(make-generic-info (quote-syntax property-name)
(quote-syntax prop:pred)
(quote-syntax accessor-name)
(list (quote-syntax method-name) ...)))
(define (prop:guard x info)
(unless (and (vector? x) (= (vector-length x) 'size))

3
racket/collects/racket/private/pre-base.rkt
View File

@ -185,7 +185,8 @@
define-in-vector-like
define-:vector-like-gen
make-in-vector-like
stream? stream-ref stream-empty? stream-first stream-rest
stream-ref stream-via-prop?
stream? stream-empty? stream-first stream-rest
prop:stream in-stream empty-stream make-do-stream
split-for-body)
(all-from "kernstruct.rkt")

42
racket/collects/racket/private/set.rkt
View File

@ -16,7 +16,6 @@
set-union! set-intersect! set-subtract! set-symmetric-difference!
(rename-out [*in-set in-set])
primitive-set/c
set-implements/c)
;; Method implementations for lists:
@ -408,47 +407,6 @@
(for/and ([sym (in-list syms)])
(set-implements? x sym)))))))
(define (primitive-set/c elem/c)
(define (proc)
(set/c
[set-member? (-> set? elem/c boolean?)]
[set-empty? (or/c (-> set? boolean?) #f)]
[set-count (or/c (-> set? exact-nonnegative-integer?) #f)]
[set=? (or/c (-> set? c boolean?) #f)]
[subset? (or/c (-> set? c boolean?) #f)]
[proper-subset? (or/c (-> set? c boolean?) #f)]
[set-map (or/c (-> set? (-> elem/c any/c) list?) #f)]
[set-for-each (or/c (-> set? (-> elem/c any) void?) #f)]
[set-copy (or/c (-> set? c) #f)]
[in-set (or/c (-> set? sequence?) #f)]
[set->list (or/c (-> set? list?) #f)]
[set->stream (or/c (-> set? stream?) #f)]
[set-first (or/c (-> set? elem/c) #f)]
[set-rest (or/c (-> set? c) #f)]
[set-add (or/c (-> set? elem/c c) #f)]
[set-remove (or/c (-> set? elem/c c) #f)]
[set-clear (or/c (-> set? c) #f)]
[set-union (or/c (->* [set?] [] #:rest (listof c) c) #f)]
[set-intersect (or/c (->* [set?] [] #:rest (listof c) c) #f)]
[set-subtract (or/c (->* [set?] [] #:rest (listof c) c) #f)]
[set-symmetric-difference (or/c (->* [set?] [] #:rest (listof c) c) #f)]
[set-add! (or/c (-> set? elem/c void?) #f)]
[set-remove! (or/c (-> set? elem/c void?) #f)]
[set-clear! (or/c (-> set? void?) #f)]
[set-union! (or/c (->* [set?] [] #:rest (listof c) void?) #f)]
[set-intersect! (or/c (->* [set?] [] #:rest (listof c) void?) #f)]
[set-subtract! (or/c (->* [set?] [] #:rest (listof c) void?) #f)]
[set-symmetric-difference!
(or/c (->* [set?] [] #:rest (listof c) void?) #f)]))
(define c
(cond
[(chaperone-contract? elem/c)
(recursive-contract (proc) #:chaperone)]
[else
(recursive-contract (proc) #:impersonator)]))
(or/c (listof elem/c)
(and/c set? c)))
;; Generics definition:
(define-generics set

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

@ -2,10 +2,11 @@
(require racket/contract
racket/private/set
racket/private/set-types)
racket/private/set-types
racket/generic
racket/private/for)
(provide (except-out (all-from-out racket/private/set)
primitive-set/c)
(provide (all-from-out racket/private/set)
(all-from-out racket/private/set-types)
set/c)
@ -42,30 +43,140 @@
[else
(unless (contract? elem/c)
(raise-argument-error 'set/c "contract?" elem/c))])
(define c
(and/c (primitive-set/c elem/c)
cmp/c
kind/c))
(define name
`(set/c ,(contract-name elem/c)
,@(if (eq? cmp 'dont-care)
`[]
`[#:cmp (quote #,cmp)])
,@(if (eq? kind 'dont-care)
`[]
`[#:kind (quote #,kind)])))
(rename-contract c name))
(cond
[(chaperone-contract? elem/c)
(chaperone-set-contract elem/c cmp kind)]
[else
(impersonator-set-contract elem/c cmp kind)]))
(define (rename-contract c name)
(define make
(cond
[(flat-contract? c) make-flat-contract]
[(chaperone-contract? c) make-chaperone-contract]
[else make-contract]))
(make
#:name name
#:first-order (contract-first-order c)
#:projection
(struct set-contract [elem/c cmp kind])
(define (set-contract-name ctc)
(define elem/c (set-contract-elem/c ctc))
(define cmp (set-contract-cmp ctc))
(define kind (set-contract-kind ctc))
`(set/c ,(contract-name elem/c)
,@(if (eq? cmp 'dont-care)
`[]
`[#:cmp (quote #,cmp)])
,@(if (eq? kind 'dont-care)
`[]
`[#:kind (quote #,kind)])))
(define (set-contract-first-order ctc)
(define cmp (set-contract-cmp ctc))
(define kind (set-contract-kind ctc))
(define cmp?
(case cmp
[(dont-care) (lambda (x) #t)]
[(equal) set-equal?]
[(eqv) set-eqv?]
[(eq) set-eq?]))
(define kind?
(case kind
[(dont-care) (lambda (x) #t)]
[(mutable-or-weak) (lambda (x) (or (set-mutable? x) (set-weak? x)))]
[(mutable) set-mutable?]
[(weak) set-weak?]
[(immutable) set-immutable?]))
(lambda (x)
(and (set? x) (cmp? x) (kind? x))))
(define (set-contract-projection mode)
(lambda (ctc)
(define elem/c (set-contract-elem/c ctc))
(define cmp (set-contract-cmp ctc))
(define kind (set-contract-kind ctc))
(lambda (b)
((contract-projection c)
(blame-add-context b #f)))))
(lambda (x)
(unless (set? x)
(raise-blame-error b x "expected a set"))
(case cmp
[(equal)
(unless (set-equal? x)
(raise-blame-error b x "expected an equal?-based set"))]
[(eqv)
(unless (set-equal? x)
(raise-blame-error b x "expected an eqv?-based set"))]
[(eq)
(unless (set-equal? x)
(raise-blame-error b x "expected an eq?-based set"))])
(case kind
[(mutable-or-weak)
(unless (or (set-mutable? x) (set-weak? x))
(raise-blame-error b x "expected a mutable or weak set"))]
[(mutable)
(unless (set-mutable? x)
(raise-blame-error b x "expected a mutable set"))]
[(weak)
(unless (set-mutable? x)
(raise-blame-error b x "expected a weak set"))]
[(immutable)
(unless (set-immutable? x)
(raise-blame-error b x "expected an immutable set"))])
(cond
[(list? x)
(define proj
((contract-projection elem/c)
(blame-add-context b "an element of")))
(map proj x)]
[else
(define (method sym c)
(lambda (x)
(define name (contract-name c))
(define str (format "method ~a with contract ~.s" sym name))
(define b2 (blame-add-context b str))
(((contract-projection c) b2) x)))
(define-syntax-rule (redirect [id expr] ...)
(redirect-generics mode gen:set x [id (method 'id expr)] ...))
(redirect
[set-member? (-> set? elem/c boolean?)]
[set-empty? (or/c (-> set? boolean?) #f)]
[set-count (or/c (-> set? exact-nonnegative-integer?) #f)]
[set=? (or/c (-> set? ctc boolean?) #f)]
[subset? (or/c (-> set? ctc boolean?) #f)]
[proper-subset? (or/c (-> set? ctc boolean?) #f)]
[set-map (or/c (-> set? (-> elem/c any/c) list?) #f)]
[set-for-each (or/c (-> set? (-> elem/c any) void?) #f)]
[set-copy (or/c (-> set? ctc) #f)]
[in-set (or/c (-> set? sequence?) #f)]
[set->list (or/c (-> set? (listof elem/c)) #f)]
[set->stream (or/c (-> set? stream?) #f)]
[set-first (or/c (-> set? elem/c) #f)]
[set-rest (or/c (-> set? ctc) #f)]
[set-add (or/c (-> set? elem/c ctc) #f)]
[set-remove (or/c (-> set? elem/c ctc) #f)]
[set-clear (or/c (-> set? ctc) #f)]
[set-union
(or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)]
[set-intersect
(or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)]
[set-subtract
(or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)]
[set-symmetric-difference
(or/c (->* [set?] [] #:rest (listof ctc) ctc) #f)]
[set-add! (or/c (-> set? elem/c void?) #f)]
[set-remove! (or/c (-> set? elem/c void?) #f)]
[set-clear! (or/c (-> set? void?) #f)]
[set-union!
(or/c (->* [set?] [] #:rest (listof ctc) void?) #f)]
[set-intersect!
(or/c (->* [set?] [] #:rest (listof ctc) void?) #f)]
[set-subtract!
(or/c (->* [set?] [] #:rest (listof ctc) void?) #f)]
[set-symmetric-difference!
(or/c (->* [set?] [] #:rest (listof ctc) void?) #f)])])))))
(struct chaperone-set-contract set-contract []
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name set-contract-name
#:first-order set-contract-first-order
#:projection (set-contract-projection #t)))
(struct impersonator-set-contract set-contract []
#:property prop:contract
(build-contract-property
#:name set-contract-name
#:first-order set-contract-first-order
#:projection (set-contract-projection #f)))

2
racket/collects/racket/stream.rkt
View File

@ -40,6 +40,8 @@
(define-syntax gen:stream
(make-generic-info (quote-syntax prop:stream)
(quote-syntax stream-via-prop?)
(quote-syntax stream-get-generics)
(list (quote-syntax stream-empty?)
(quote-syntax stream-first)
(quote-syntax stream-rest))))