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

got rid of define-struct/prop since scheme/base has a define-struct that does all that (and more) now

Browse Source 
svn: r11727
This commit is contained in:
Robby Findler 2008-09-13 16:29:01 +00:00
parent c6c876a821
commit 06a4d0df4a
6 changed files with 585 additions and 568 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/mzlib/private/contract-arrow.ss
View File

@ -62,8 +62,10 @@
;; func : the wrapper function maker. It accepts a procedure for ;; func : the wrapper function maker. It accepts a procedure for
;; checking the first-order properties and the contracts ;; checking the first-order properties and the contracts
;; and it produces a wrapper-making function. ;; and it produces a wrapper-making function.
(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func) (define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
((proj-prop (λ (ctc) #:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x)) (let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc))) (append (->-doms ctc) (list (->-dom-rest ctc)))
@ -86,15 +88,17 @@
(if has-rest? (if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str) (check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str))) (check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
(append partial-doms partial-ranges partial-kwds))))))) (append partial-doms partial-ranges partial-kwds))))))
(name-prop (λ (ctc) (single-arrow-name-maker
#:property name-prop
(λ (ctc) (single-arrow-name-maker
(->-doms ctc) (->-doms ctc)
(->-dom-rest ctc) (->-dom-rest ctc)
(->-kwds ctc) (->-kwds ctc)
(->-quoted-kwds ctc) (->-quoted-kwds ctc)
(->-rng-any? ctc) (->-rng-any? ctc)
(->-rngs ctc)))) (->-rngs ctc)))
(first-order-prop #:property first-order-prop
(λ (ctc) (λ (ctc)
(let ([l (length (->-doms ctc))]) (let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
@ -104,8 +108,8 @@
(λ (x) (λ (x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x l) (procedure-arity-includes? x l)
(no-mandatory-keywords? x))))))) (no-mandatory-keywords? x))))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
(= (length (->-doms that)) (= (length (->-doms that))
@ -117,7 +121,7 @@
(length (->-rngs this))) (length (->-rngs this)))
(andmap contract-stronger? (andmap contract-stronger?
(->-rngs this) (->-rngs this)
(->-rngs that))))))) (->-rngs that)))))
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs) (define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
(cond (cond

80
collects/scheme/private/contract-arrow.ss
View File

@ -86,18 +86,6 @@ v4 todo:
; ;
(define (build--> name
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
rngs/c-or-p
rng-any? func)
(let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
(make-->
(map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
(map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
(map cc rngs/c-or-p) rng-any?
func)))
;; doms : (listof contract) ;; doms : (listof contract)
;; optional-doms/c : (listof contract) ;; optional-doms/c : (listof contract)
;; dom-rest : (or/c false/c contract) ;; dom-rest : (or/c false/c contract)
@ -110,8 +98,10 @@ v4 todo:
;; func : the wrapper function maker. It accepts a procedure for ;; func : the wrapper function maker. It accepts a procedure for
;; checking the first-order properties and the contracts ;; checking the first-order properties and the contracts
;; and it produces a wrapper-making function. ;; and it produces a wrapper-making function.
(define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func) (define-struct -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
((proj-prop (λ (ctc) #:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([doms-proj (map (λ (x) ((proj-get x) x)) (let* ([doms-proj (map (λ (x) ((proj-get x) x))
(if (->-dom-rest/c ctc) (if (->-dom-rest/c ctc)
(append (->-doms/c ctc) (list (->-dom-rest/c ctc))) (append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
@ -144,8 +134,10 @@ v4 todo:
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
(append partial-doms partial-optional-doms (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds partial-mandatory-kwds partial-optional-kwds
partial-ranges))))))) partial-ranges))))))
(name-prop (λ (ctc) (single-arrow-name-maker
#:property name-prop
(λ (ctc) (single-arrow-name-maker
(->-doms/c ctc) (->-doms/c ctc)
(->-optional-doms/c ctc) (->-optional-doms/c ctc)
(->-dom-rest/c ctc) (->-dom-rest/c ctc)
@ -154,8 +146,9 @@ v4 todo:
(->-optional-kwds/c ctc) (->-optional-kwds/c ctc)
(->-optional-kwds ctc) (->-optional-kwds ctc)
(->-rng-any? ctc) (->-rng-any? ctc)
(->-rngs/c ctc)))) (->-rngs/c ctc)))
(first-order-prop
#:property first-order-prop
(λ (ctc) (λ (ctc)
(λ (x) (λ (x)
(let ([l (length (->-doms/c ctc))]) (let ([l (length (->-doms/c ctc))])
@ -167,8 +160,8 @@ v4 todo:
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc)) (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords)) (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
(->-mandatory-kwds ctc)))) (->-mandatory-kwds ctc))))
#t))))) #t))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
(= (length (->-doms/c that)) (length (->-doms/c this))) (= (length (->-doms/c that)) (length (->-doms/c this)))
@ -181,7 +174,19 @@ v4 todo:
(andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this)) (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
(= (length (->-rngs/c that)) (length (->-rngs/c this))) (= (length (->-rngs/c that)) (length (->-rngs/c this)))
(andmap contract-stronger? (->-rngs/c this) (->-rngs/c that))))))) (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))
(define (build--> name
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
rngs/c-or-p
rng-any? func)
(let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
(make-->
(map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
(map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
(map cc rngs/c-or-p) rng-any?
func)))
(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs) (define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs)
(cond (cond
@ -1014,7 +1019,7 @@ v4 todo:
;; the `box' in the range only serves to differentiate between range contracts that depend on ;; the `box' in the range only serves to differentiate between range contracts that depend on
;; both the domain and the range from those that depend only on the domain (and thus, those ;; both the domain and the range from those that depend only on the domain (and thus, those
;; that can be applied early) ;; that can be applied early)
(define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. (define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
mandatory-dom-ctcs ;; (listof (-> d??? ctc)) mandatory-dom-ctcs ;; (listof (-> d??? ctc))
optional-dom-ctcs ;; (listof (-> d??? ctc)) optional-dom-ctcs ;; (listof (-> d??? ctc))
keyword-ctcs ;; (listof (-> d??? ctc)) keyword-ctcs ;; (listof (-> d??? ctc))
@ -1026,8 +1031,12 @@ v4 todo:
mandatory-keywords ;; (listof keywords) -- sorted by keyword< mandatory-keywords ;; (listof keywords) -- sorted by keyword<
optional-keywords ;; (listof keywords) -- sorted by keyword< optional-keywords ;; (listof keywords) -- sorted by keyword<
name-wrapper) ;; (-> proc proc) name-wrapper) ;; (-> proc proc)
((proj-prop ->d-proj)
(name-prop (λ (ctc) #:omit-define-syntaxes
#:property proj-prop ->d-proj
#:property name-prop
(λ (ctc)
(let* ([counting-id 'x] (let* ([counting-id 'x]
[ids '(x y z w)] [ids '(x y z w)]
[next-id [next-id
@ -1072,9 +1081,10 @@ v4 todo:
`(values ,@(map (λ (x) `(,(next-id) ...)) range))])) `(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
,@(if (->d-post-cond ctc) ,@(if (->d-post-cond ctc)
(list '#:post-cond '...) (list '#:post-cond '...)
(list)))))) (list)))))
(first-order-prop (λ (ctc) (λ (x) #f)))
(stronger-prop (λ (this that) (eq? this that))))) #:property first-order-prop (λ (ctc) (λ (x) #f))
#:property stronger-prop (λ (this that) (eq? this that)))
; ;
@ -1180,8 +1190,9 @@ v4 todo:
;; rng-ctcs : (listof (listof contract)) ;; rng-ctcs : (listof (listof contract))
;; specs : (listof (list boolean exact-positive-integer)) ;; indicates the required arities of the input functions ;; specs : (listof (list boolean exact-positive-integer)) ;; indicates the required arities of the input functions
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections ;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections
(define-struct/prop case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper) (define-struct case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)
((proj-prop #:omit-define-syntaxes
#:property proj-prop
(λ (ctc) (λ (ctc)
(let* ([to-proj (λ (c) ((proj-get c) c))] (let* ([to-proj (λ (c) ((proj-get c) c))]
[dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))] [dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))]
@ -1211,8 +1222,9 @@ v4 todo:
specs rst-ctcs)]))]) specs rst-ctcs)]))])
(apply (case->-wrapper ctc) (apply (case->-wrapper ctc)
chk chk
projs)))))) projs)))))
(name-prop (λ (ctc) (apply #:property name-prop
(λ (ctc) (apply
build-compound-type-name build-compound-type-name
'case-> 'case->
(map (λ (dom rst range) (map (λ (dom rst range)
@ -1231,9 +1243,9 @@ v4 todo:
[else (apply build-compound-type-name 'values range)]))))) [else (apply build-compound-type-name 'values range)])))))
(case->-dom-ctcs ctc) (case->-dom-ctcs ctc)
(case->-rst-ctcs ctc) (case->-rst-ctcs ctc)
(case->-rng-ctcs ctc))))) (case->-rng-ctcs ctc))))
(first-order-prop (λ (ctc) (λ (val) #f))) #:property first-order-prop (λ (ctc) (λ (val) #f))
(stronger-prop (λ (this that) #f)))) #:property stronger-prop (λ (this that) #f))
(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper) (define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)
(make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs) (make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)

135
collects/scheme/private/contract-guts.ss
View File

@ -33,8 +33,6 @@
make-proj-contract make-proj-contract
build-flat-contract build-flat-contract
define-struct/prop
contract-stronger? contract-stronger?
contract-first-order-passes? contract-first-order-passes?
@ -55,49 +53,6 @@
(define-syntax (any stx) (define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
;; define-struct/prop is a define-struct-like macro that
;; also allows properties to be defined
;; it contains copied code (build-struct-names) in order to avoid
;; a module cycle
(define-syntax (define-struct/prop stx)
(let ()
(syntax-case stx ()
[(_ name (field ...) ((property value) ...))
(andmap identifier? (syntax->list (syntax (field ...))))
(let ([struct-names (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#f
#t
stx)]
[struct-names/bangers (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#t
#f
stx)]
[field-count/val (length (syntax->list (syntax (field ...))))])
(with-syntax ([struct:-name (list-ref struct-names 0)]
[struct-maker (list-ref struct-names 1)]
[predicate (list-ref struct-names 2)]
[(count ...) (nums-up-to field-count/val)]
[(selectors ...) (cdddr struct-names)]
[(bangers ...) (cdddr struct-names/bangers)]
[field-count field-count/val]
[(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))])
(syntax
(begin
(define-values (struct:-name struct-maker predicate get set)
(make-struct-type 'name
#f ;; super
field-count
0 ;; auto-field-k
'()
(list (cons property value) ...)))
(define selectors (make-struct-field-accessor get count 'field))
...
(define bangers (make-struct-field-mutator set count 'field))
...))))])))
(define-values (proj-prop proj-pred? raw-proj-get) (define-values (proj-prop proj-pred? raw-proj-get)
(make-struct-type-property 'contract-projection)) (make-struct-type-property 'contract-projection))
(define-values (name-prop name-pred? name-get) (define-values (name-prop name-pred? name-get)
@ -145,9 +100,14 @@
[(contract? x) x] [(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1)) [(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)] (flat-contract x)]
;[(symbol? x) (symbol-contract x)]
;[(char? x) (char-contract x)]
;[(boolean? x) (boolean-contract x)]
;[(regexp? x) (regexp-contract x)]
;[(string? x) (string-contract x)]
[else [else
(error name (error name
"expected contract or procedure of arity 1, got ~e" "expected contract or a value that can be coerced into one, got ~e"
x)])) x)]))
(define-values (make-exn:fail:contract2 (define-values (make-exn:fail:contract2
@ -177,7 +137,12 @@
(define (default-contract-violation->string val src-info to-blame contract-sexp msg) (define (default-contract-violation->string val src-info to-blame contract-sexp msg)
(let ([blame-src (src-info-as-string src-info)] (let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp [formatted-contract-sexp
(let ([one-line (format "~s" contract-sexp)]) (let ([one-line
(let ([sp (open-output-string)])
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30) (if (< (string-length one-line) 30)
one-line one-line
(let ([sp (open-output-string)]) (let ([sp (open-output-string)])
@ -312,25 +277,33 @@
(define-values (make-flat-contract (define-values (make-flat-contract
make-proj-contract) make-proj-contract)
(let () (let ()
(define-struct/prop proj-contract (the-name proj first-order-proc) (define-struct proj-contract (the-name proj first-order-proc)
((proj-prop (λ (ctc) (proj-contract-proj ctc))) #:property proj-prop
(name-prop (λ (ctc) (proj-contract-the-name ctc))) (λ (ctc) (proj-contract-proj ctc))
(first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc)
(λ (x) #t)))) #:property name-prop
(stronger-prop (λ (this that) (λ (ctc) (proj-contract-the-name ctc))
#:property first-order-prop
(λ (ctc) (or (proj-contract-first-order-proc ctc)
(λ (x) #t)))
#:property stronger-prop
(λ (this that)
(and (proj-contract? that) (and (proj-contract? that)
(procedure-closure-contents-eq? (procedure-closure-contents-eq?
(proj-contract-proj this) (proj-contract-proj this)
(proj-contract-proj that))))))) (proj-contract-proj that)))))
(define-struct/prop flat-contract (the-name predicate) (define-struct flat-contract (the-name predicate)
((proj-prop flat-proj) #:property proj-prop flat-proj
(stronger-prop (λ (this that) #:property stronger-prop
(λ (this that)
(and (flat-contract? that) (and (flat-contract? that)
(procedure-closure-contents-eq? (flat-contract-predicate this) (procedure-closure-contents-eq? (flat-contract-predicate this)
(flat-contract-predicate that))))) (flat-contract-predicate that))))
(name-prop (λ (ctc) (flat-contract-the-name ctc))) #:property name-prop (λ (ctc) (flat-contract-the-name ctc))
(flat-prop (λ (ctc) (flat-contract-predicate ctc))))) #:property flat-prop (λ (ctc) (flat-contract-predicate ctc)))
(values make-flat-contract (values make-flat-contract
make-proj-contract))) make-proj-contract)))
@ -398,14 +371,16 @@
(λ (v) (proj (f v)))))])))))) (λ (v) (proj (f v)))))]))))))
(define-struct/prop and/c (ctcs) (define-struct and/c (ctcs)
((proj-prop and-proj) #:omit-define-syntaxes
(name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))) #:property proj-prop and-proj
(first-order-prop (λ (ctc) #:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
#:property first-order-prop
(λ (ctc)
(let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))]) (let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))])
(λ (x) (λ (x)
(andmap (λ (f) (f x)) tests))))) (andmap (λ (f) (f x)) tests))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (and/c? that) (and (and/c? that)
(let ([this-ctcs (and/c-ctcs this)] (let ([this-ctcs (and/c-ctcs this)]
@ -413,7 +388,7 @@
(and (= (length this-ctcs) (length that-ctcs)) (and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? (andmap contract-stronger?
this-ctcs this-ctcs
that-ctcs)))))))) that-ctcs))))))
(define (and/c . fs) (define (and/c . fs)
(for-each (for-each
@ -447,12 +422,13 @@
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]) (let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
(make-and/c contracts))])) (make-and/c contracts))]))
(define-struct/prop any/c () (define-struct any/c ()
((proj-prop double-any-curried-proj) #:omit-define-syntaxes
(stronger-prop (λ (this that) (any/c? that))) #:property proj-prop double-any-curried-proj
(name-prop (λ (ctc) 'any/c)) #:property stronger-prop (λ (this that) (any/c? that))
(first-order-prop (λ (ctc) (λ (val) #t))) #:property name-prop (λ (ctc) 'any/c)
(flat-prop (λ (ctc) (λ (x) #t))))) #:property first-order-prop (λ (ctc) (λ (val) #t))
#:property flat-prop (λ (ctc) (λ (x) #t)))
(define any/c (make-any/c)) (define any/c (make-any/c))
@ -468,12 +444,13 @@
(none/c-name ctc) (none/c-name ctc)
val)))) val))))
(define-struct/prop none/c (name) (define-struct none/c (name)
((proj-prop none-curried-proj) #:omit-define-syntaxes
(stronger-prop (λ (this that) #t)) #:property proj-prop none-curried-proj
(name-prop (λ (ctc) (none/c-name ctc))) #:property stronger-prop (λ (this that) #t)
(first-order-prop (λ (ctc) (λ (val) #f))) #:property name-prop (λ (ctc) (none/c-name ctc))
(flat-prop (λ (ctc) (λ (x) #f))))) #:property first-order-prop (λ (ctc) (λ (val) #f))
#:property flat-prop (λ (ctc) (λ (x) #f)))
(define none/c (make-none/c 'none/c)) (define none/c (make-none/c 'none/c))

17
collects/scheme/private/contract-object.ss
View File

@ -50,8 +50,9 @@
[_ [_
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])]))) (raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
(define-struct/prop object-contract (methods method-ctcs method-wrappers fields field-ctcs) (define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs)
((proj-prop #:omit-define-syntaxes
#:property proj-prop
(λ (ctc) (λ (ctc)
(let ([meth-names (object-contract-methods ctc)] (let ([meth-names (object-contract-methods ctc)]
[meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))] [meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))]
@ -97,15 +98,17 @@
(apply make-object cls val (apply make-object cls val
(map (λ (field proj) (proj (get-field/proc field val))) (map (λ (field proj) (proj (get-field/proc field val)))
ctc-field-names field-projs)))))))) ctc-field-names field-projs)))))))
(name-prop (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) #:property name-prop
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc) (object-contract-fields ctc)
(object-contract-field-ctcs ctc)) (object-contract-field-ctcs ctc))
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc)) ,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
(object-contract-methods ctc) (object-contract-methods ctc)
(object-contract-method-ctcs ctc))))) (object-contract-method-ctcs ctc))))
(first-order-prop (λ (ctc) (λ (val) #f)))
(stronger-prop (λ (this that) #f)))) #:property first-order-prop (λ (ctc) (λ (val) #f))
#:property stronger-prop (λ (this that) #f))
(define-syntax (object-contract stx) (define-syntax (object-contract stx)
(syntax-case stx () (syntax-case stx ()

13
collects/scheme/private/contract-opt.ss
View File

@ -175,16 +175,17 @@
(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
(make-struct-type-property 'original-contract)) (make-struct-type-property 'original-contract))
(define-struct/prop opt-contract (proj orig-ctc stronger stronger-vars stamp) (define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp)
((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))) #:property proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))
;; I think provide/contract and contract calls this, so we are in effect allocating ;; I think provide/contract and contract calls this, so we are in effect allocating
;; the original once ;; the original once
(name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))) #:property name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
(orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))) #:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))
(stronger-prop (λ (this that) #:property stronger-prop
(λ (this that)
(and (opt-contract? that) (and (opt-contract? that)
(eq? (opt-contract-stamp this) (opt-contract-stamp that)) (eq? (opt-contract-stamp this) (opt-contract-stamp that))
((opt-contract-stronger this) this that)))))) ((opt-contract-stronger this) this that))))
;; opt-stronger-vars-ref : int opt-contract -> any ;; opt-stronger-vars-ref : int opt-contract -> any
(define (opt-stronger-vars-ref i ctc) (define (opt-stronger-vars-ref i ctc)

116
collects/scheme/private/contract.ss
View File

@ -939,8 +939,10 @@ improve method arity mismatch contract violation error messages?
[else [else
(make-multi-or/c flat-contracts ho-contracts)])))])) (make-multi-or/c flat-contracts ho-contracts)])))]))
(define-struct/prop or/c (pred flat-ctcs ho-ctc) (define-struct or/c (pred flat-ctcs ho-ctc)
((proj-prop (λ (ctc) #:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] (let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
[pred (or/c-pred ctc)]) [pred (or/c-pred ctc)])
(λ (pos-blame neg-blame src-info orig-str) (λ (pos-blame neg-blame src-info orig-str)
@ -949,22 +951,24 @@ improve method arity mismatch contract violation error messages?
(cond (cond
[(pred val) val] [(pred val) val]
[else [else
(partial-contract val)]))))))) (partial-contract val)]))))))
(name-prop (λ (ctc) #:property name-prop
(λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
(or/c-ho-ctc ctc) (or/c-ho-ctc ctc)
(or/c-flat-ctcs ctc)))) (or/c-flat-ctcs ctc)))
(first-order-prop
#:property first-order-prop
(λ (ctc) (λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))] (let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))]
[ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]) [ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
(λ (x) (λ (x)
(or (ho x) (or (ho x)
(ormap (λ (f) (f x)) flats)))))) (ormap (λ (f) (f x)) flats)))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (or/c? that) (and (or/c? that)
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
@ -973,7 +977,7 @@ improve method arity mismatch contract violation error messages?
(and (= (length this-ctcs) (length that-ctcs)) (and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? (andmap contract-stronger?
this-ctcs this-ctcs
that-ctcs)))))))) that-ctcs))))))
(define (multi-or/c-proj ctc) (define (multi-or/c-proj ctc)
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
@ -1017,23 +1021,25 @@ improve method arity mismatch contract violation error messages?
candidate-proc candidate-proc
candidate-contract)]))])))))) candidate-contract)]))]))))))
(define-struct/prop multi-or/c (flat-ctcs ho-ctcs) (define-struct multi-or/c (flat-ctcs ho-ctcs)
((proj-prop multi-or/c-proj) #:property proj-prop multi-or/c-proj
(name-prop (λ (ctc) #:property name-prop
(λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
(append (append
(multi-or/c-flat-ctcs ctc) (multi-or/c-flat-ctcs ctc)
(reverse (multi-or/c-ho-ctcs ctc)))))) (reverse (multi-or/c-ho-ctcs ctc)))))
(first-order-prop
#:property first-order-prop
(λ (ctc) (λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))] (let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
[hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))]) [hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
(λ (x) (λ (x)
(or (ormap (λ (f) (f x)) hos) (or (ormap (λ (f) (f x)) hos)
(ormap (λ (f) (f x)) flats)))))) (ormap (λ (f) (f x)) flats)))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (multi-or/c? that) (and (multi-or/c? that)
(let ([this-ctcs (multi-or/c-ho-ctcs this)] (let ([this-ctcs (multi-or/c-ho-ctcs this)]
@ -1047,15 +1053,16 @@ improve method arity mismatch contract violation error messages?
(and (= (length this-ctcs) (length that-ctcs)) (and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? (andmap contract-stronger?
this-ctcs this-ctcs
that-ctcs)))))))) that-ctcs))))))
(define-struct/prop flat-or/c (pred flat-ctcs) (define-struct flat-or/c (pred flat-ctcs)
((proj-prop flat-proj) #:property proj-prop flat-proj
(name-prop (λ (ctc) #:property name-prop
(λ (ctc)
(apply build-compound-type-name (apply build-compound-type-name
'or/c 'or/c
(flat-or/c-flat-ctcs ctc)))) (flat-or/c-flat-ctcs ctc)))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
(and (flat-or/c? that) (and (flat-or/c? that)
(let ([this-ctcs (flat-or/c-flat-ctcs this)] (let ([this-ctcs (flat-or/c-flat-ctcs this)]
@ -1063,8 +1070,10 @@ improve method arity mismatch contract violation error messages?
(and (= (length this-ctcs) (length that-ctcs)) (and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? (andmap contract-stronger?
this-ctcs this-ctcs
that-ctcs)))))) that-ctcs)))))
(flat-prop (λ (ctc) (flat-or/c-pred ctc)))))
#:property flat-prop
(λ (ctc) (flat-or/c-pred ctc)))
;; ;;
;; or/c opter ;; or/c opter
@ -1240,17 +1249,20 @@ improve method arity mismatch contract violation error messages?
[else (error 'one-of-pc "undef ~s" x)])) [else (error 'one-of-pc "undef ~s" x)]))
(define-struct/prop one-of/c (elems) (define-struct one-of/c (elems)
((proj-prop flat-proj) #:omit-define-syntaxes
(name-prop (λ (ctc) #:property proj-prop flat-proj
#:property name-prop
(λ (ctc)
(let ([elems (one-of/c-elems ctc)]) (let ([elems (one-of/c-elems ctc)])
`(,(cond `(,(cond
[(andmap symbol? elems) [(andmap symbol? elems)
'symbols] 'symbols]
[else [else
'one-of/c]) 'one-of/c])
,@(map one-of-pc elems))))) ,@(map one-of-pc elems))))
(stronger-prop
#:property stronger-prop
(λ (this that) (λ (this that)
(and (one-of/c? that) (and (one-of/c? that)
(let ([this-elems (one-of/c-elems this)] (let ([this-elems (one-of/c-elems this)]
@ -1258,11 +1270,11 @@ improve method arity mismatch contract violation error messages?
(and (and
(andmap (λ (this-elem) (memv this-elem that-elems)) (andmap (λ (this-elem) (memv this-elem that-elems))
this-elems) this-elems)
#t))))) #t))))
(flat-prop #:property flat-prop
(λ (ctc) (λ (ctc)
(let ([elems (one-of/c-elems ctc)]) (let ([elems (one-of/c-elems ctc)])
(λ (x) (memv x elems))))))) (λ (x) (memv x elems)))))
(define printable/c (define printable/c
(flat-named-contract (flat-named-contract
@ -1286,27 +1298,32 @@ improve method arity mismatch contract violation error messages?
(and (box? x) (and (box? x)
(printable? (unbox x)))))))) (printable? (unbox x))))))))
(define-struct/prop between/c (low high) (define-struct between/c (low high)
((proj-prop flat-proj) #:omit-define-syntaxes
(name-prop (λ (ctc) #:property proj-prop flat-proj
#:property name-prop
(λ (ctc)
(let ([n (between/c-low ctc)] (let ([n (between/c-low ctc)]
[m (between/c-high ctc)]) [m (between/c-high ctc)])
(cond (cond
[(= n -inf.0) `(<=/c ,m)] [(= n -inf.0) `(<=/c ,m)]
[(= m +inf.0) `(>=/c ,n)] [(= m +inf.0) `(>=/c ,n)]
[(= n m) `(=/c ,n)] [(= n m) `(=/c ,n)]
[else `(between/c ,n ,m)])))) [else `(between/c ,n ,m)])))
(stronger-prop
#:property stronger-prop
(λ (this that) (λ (this that)
(and (between/c? that) (and (between/c? that)
(<= (between/c-low that) (between/c-low this)) (<= (between/c-low that) (between/c-low this))
(<= (between/c-high this) (between/c-high that))))) (<= (between/c-high this) (between/c-high that))))
(flat-prop (λ (ctc)
#:property flat-prop
(λ (ctc)
(let ([n (between/c-low ctc)] (let ([n (between/c-low ctc)]
[m (between/c-high ctc)]) [m (between/c-high ctc)])
(λ (x) (λ (x)
(and (number? x) (and (number? x)
(<= n x m)))))))) (<= n x m))))))
(define-syntax (check-unary-between/c stx) (define-syntax (check-unary-between/c stx)
(syntax-case stx () (syntax-case stx ()
@ -1922,8 +1939,10 @@ improve method arity mismatch contract violation error messages?
(define (parameter/c x) (define (parameter/c x)
(make-parameter/c (coerce-contract 'parameter/c x))) (make-parameter/c (coerce-contract 'parameter/c x)))
(define-struct/prop parameter/c (ctc) (define-struct parameter/c (ctc)
((proj-prop (λ (ctc) #:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) (let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
(λ (pos-blame neg-blame src-info orig-str) (λ (pos-blame neg-blame src-info orig-str)
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)] (let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)]
@ -1937,16 +1956,17 @@ improve method arity mismatch contract violation error messages?
partial-pos-contract)] partial-pos-contract)]
[else [else
(raise-contract-error val src-info pos-blame orig-str (raise-contract-error val src-info pos-blame orig-str
"expected a parameter")]))))))) "expected a parameter")]))))))
(name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))))
(first-order-prop #:property name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
#:property first-order-prop
(λ (ctc) (λ (ctc)
(let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) (let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
(λ (x) (λ (x)
(and (parameter? x) (and (parameter? x)
(tst (x))))))) (tst (x))))))
(stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
;; must be invariant (because the library doesn't currently split out pos/neg contracts ;; must be invariant (because the library doesn't currently split out pos/neg contracts
;; which could be tested individually ....) ;; which could be tested individually ....)
@ -1954,5 +1974,5 @@ improve method arity mismatch contract violation error messages?
(contract-stronger? (parameter/c-ctc this) (contract-stronger? (parameter/c-ctc this)
(parameter/c-ctc that)) (parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that) (contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this))))))) (parameter/c-ctc this)))))