From 2f473c24030d824da4973738170232624c23a5bd Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 24 Jul 2013 17:06:29 -0400 Subject: [PATCH] Added tools for contracts, impersonators, and chaperones for generic interfaces. 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. --- racket/collects/racket/generic.rkt | 268 ++++++++++-------- racket/collects/racket/private/for.rkt | 2 +- .../racket/private/generic-interfaces.rkt | 4 + .../racket/private/generic-methods.rkt | 115 ++++++-- racket/collects/racket/private/generic.rkt | 2 + racket/collects/racket/private/pre-base.rkt | 3 +- racket/collects/racket/private/set.rkt | 42 --- racket/collects/racket/set.rkt | 167 +++++++++-- racket/collects/racket/stream.rkt | 2 + 9 files changed, 387 insertions(+), 218 deletions(-) diff --git a/racket/collects/racket/generic.rkt b/racket/collects/racket/generic.rkt index 7bfd1e996b..468b57e8b8 100644 --- a/racket/collects/racket/generic.rkt +++ b/racket/collects/racket/generic.rkt @@ -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))) diff --git a/racket/collects/racket/private/for.rkt b/racket/collects/racket/private/for.rkt index 918d9503ba..60b236e383 100644 --- a/racket/collects/racket/private/for.rkt +++ b/racket/collects/racket/private/for.rkt @@ -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 diff --git a/racket/collects/racket/private/generic-interfaces.rkt b/racket/collects/racket/private/generic-interfaces.rkt index d7db6c13b2..2c4426dd3d 100644 --- a/racket/collects/racket/private/generic-interfaces.rkt +++ b/racket/collects/racket/private/generic-interfaces.rkt @@ -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)))) ) diff --git a/racket/collects/racket/private/generic-methods.rkt b/racket/collects/racket/private/generic-methods.rkt index 76faaa9125..8043b0e31a 100644 --- a/racket/collects/racket/private/generic-methods.rkt +++ b/racket/collects/racket/private/generic-methods.rkt @@ -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)))]))) diff --git a/racket/collects/racket/private/generic.rkt b/racket/collects/racket/private/generic.rkt index 17d47ddfca..e14ec8b818 100644 --- a/racket/collects/racket/private/generic.rkt +++ b/racket/collects/racket/private/generic.rkt @@ -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)) diff --git a/racket/collects/racket/private/pre-base.rkt b/racket/collects/racket/private/pre-base.rkt index 2dfc85c0ab..8266105f22 100644 --- a/racket/collects/racket/private/pre-base.rkt +++ b/racket/collects/racket/private/pre-base.rkt @@ -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") diff --git a/racket/collects/racket/private/set.rkt b/racket/collects/racket/private/set.rkt index fbaa4c7a1b..1498fe34c6 100644 --- a/racket/collects/racket/private/set.rkt +++ b/racket/collects/racket/private/set.rkt @@ -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 diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt index 6b6eae0eff..a0ee57d89a 100644 --- a/racket/collects/racket/set.rkt +++ b/racket/collects/racket/set.rkt @@ -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))) diff --git a/racket/collects/racket/stream.rkt b/racket/collects/racket/stream.rkt index 993887ec54..3bf9d8d713 100644 --- a/racket/collects/racket/stream.rkt +++ b/racket/collects/racket/stream.rkt @@ -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))))