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

Fix contract names for ->m, ->*m, case->m, and ->dm contracts.

Browse Source 
This should be merged into the 5.3 release branch.
This commit is contained in:
Stevie Strickland 2012-04-18 15:24:43 -04:00
parent 62408cc727
commit d76b0dac78
3 changed files with 48 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/racket/contract/private/arrow.rkt
View File

@ -44,6 +44,7 @@ v4 todo:
(rename-out [-predicate/c predicate/c]) (rename-out [-predicate/c predicate/c])
unsupplied-arg? unsupplied-arg?
making-a-method making-a-method
method-contract?
procedure-accepts-and-more? procedure-accepts-and-more?
check-procedure check-procedure
check-procedure/more check-procedure/more
@ -55,6 +56,7 @@ v4 todo:
bad-number-of-results) bad-number-of-results)
(define-syntax-parameter making-a-method #f) (define-syntax-parameter making-a-method #f)
(define-syntax-parameter method-contract? #f)
(define-for-syntax (make-this-parameters id) (define-for-syntax (make-this-parameters id)
(if (syntax-parameter-value #'making-a-method) (if (syntax-parameter-value #'making-a-method)
(list id) (list id)
@ -436,6 +438,8 @@ v4 todo:
;; optional-kwds : (listof keyword) -- must be sorted by keyword< ;; optional-kwds : (listof keyword) -- must be sorted by keyword<
;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any ;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
;; rng-any? : boolean ;; rng-any? : boolean
;; mtd? : contract is for a method (implicit this in first position)
;; mctc? : contract was formed with ->m or ->*m (so print out same way)
;; 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.
@ -444,7 +448,7 @@ v4 todo:
mandatory-kwds/c mandatory-kwds mandatory-kwds/c mandatory-kwds
optional-kwds/c optional-kwds optional-kwds/c optional-kwds
rngs/c rng-any? rngs/c rng-any?
mtd? mtd? mctc?
func)) func))
(define ((->-proj wrapper) ctc) (define ((->-proj wrapper) ctc)
@ -517,7 +521,8 @@ v4 todo:
(base->-rng-any? ctc) (base->-rng-any? ctc)
(base->-rngs/c ctc) (base->-rngs/c ctc)
(base->-pre ctc) (base->-pre ctc)
(base->-post ctc))) (base->-post ctc)
(base->-mctc? ctc)))
(define (->-first-order ctc) (define (->-first-order ctc)
(λ (x) (λ (x)
@ -606,7 +611,7 @@ v4 todo:
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f 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 mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
rngs/c-or-p rngs/c-or-p
rng-any? mtd? func) rng-any? mtd? ->m-ctc? func)
(let ([cc (λ (c-or-p) (coerce-contract name c-or-p))]) (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
(let ([doms/c (map cc doms/c-or-p)] (let ([doms/c (map cc doms/c-or-p)]
[opt-doms/c (map cc optional-doms/c-or-p)] [opt-doms/c (map cc optional-doms/c-or-p)]
@ -622,18 +627,19 @@ v4 todo:
(or rng-any? (andmap chaperone-contract? rngs/c))) (or rng-any? (andmap chaperone-contract? rngs/c)))
(make-chaperone-> pre post doms/c opt-doms/c rest/c (make-chaperone-> pre post doms/c opt-doms/c rest/c
kwds/c mandatory-kwds opt-kwds/c optional-kwds kwds/c mandatory-kwds opt-kwds/c optional-kwds
rngs/c rng-any? mtd? func) rngs/c rng-any? mtd? ->m-ctc? func)
(make-impersonator-> pre post doms/c opt-doms/c rest/c (make-impersonator-> pre post doms/c opt-doms/c rest/c
kwds/c mandatory-kwds opt-kwds/c optional-kwds kwds/c mandatory-kwds opt-kwds/c optional-kwds
rngs/c rng-any? mtd? func))))) rngs/c rng-any? mtd? ->m-ctc? func)))))
(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post) (define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs pre post ->m-ctc?)
(cond (cond
[(or doms-rest [(or doms-rest
(not (null? optional-kwds)) (not (null? optional-kwds))
(not (null? optional-doms/c)) (not (null? optional-doms/c))
pre post) pre post)
(let ([range (let ([name (if ->m-ctc? '->*m '->*)]
[range
(cond (cond
[rng-any? 'any] [rng-any? 'any]
[(and (pair? rngs) [(and (pair? rngs)
@ -642,7 +648,7 @@ v4 todo:
[else (apply build-compound-type-name 'values rngs)])]) [else (apply build-compound-type-name 'values rngs)])])
(apply (apply
build-compound-type-name build-compound-type-name
'->* name
(apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c)))) (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
(append (let ([opts (append (let ([opts
(apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))]) (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))])
@ -660,14 +666,15 @@ v4 todo:
(list '#:post '...) (list '#:post '...)
(list)))))] (list)))))]
[else [else
(let ([rng-name (let ([name (if ->m-ctc? '->m '->)]
[rng-name
(cond (cond
[rng-any? 'any] [rng-any? 'any]
[(null? rngs) '(values)] [(null? rngs) '(values)]
[(null? (cdr rngs)) (car rngs)] [(null? (cdr rngs)) (car rngs)]
[else (apply build-compound-type-name 'values rngs)])]) [else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name (apply build-compound-type-name
'-> name
(append doms/c (append doms/c
(apply append (map list kwds kwds/c)) (apply append (map list kwds kwds/c))
(list rng-name))))])) (list rng-name))))]))
@ -745,6 +752,7 @@ v4 todo:
[(kwds ...) kwds] [(kwds ...) kwds]
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
[outer-lambda [outer-lambda
#`(lambda (blame val dom-names ... kwd-names ... rng-names ...) #`(lambda (blame val dom-names ... kwd-names ... rng-names ...)
#,(create-chaperone #,(create-chaperone
@ -762,7 +770,7 @@ v4 todo:
(list dom-ctcs ...) '() #f (list dom-ctcs ...) '() #f
(list kwd-ctcs ...) '(kwds ...) '() '() (list kwd-ctcs ...) '(kwds ...) '() '()
(list rng-ctcs ...) use-any? (list rng-ctcs ...) use-any?
mtd? mtd? ->m-ctc?
outer-lambda)) outer-lambda))
'racket/contract:contract 'racket/contract:contract
(vector this-> (vector this->
@ -888,6 +896,7 @@ v4 todo:
(with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)] (with-syntax ([mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)]
[(rng-proj ...) (generate-temporaries (or rng-ctc '()))] [(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
[(rng ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))]
[(this-parameter ...) [(this-parameter ...)
@ -908,7 +917,7 @@ v4 todo:
#'(list rng-ctc ...)) #'(list rng-ctc ...))
#''()) #''())
#,(if rng-ctc #f #t) #,(if rng-ctc #f #t)
mtd? mtd? ->m-ctc?
(λ (blame f (λ (blame f
mandatory-dom-proj ... mandatory-dom-proj ...
#,@(if rest-ctc #,@(if rest-ctc
@ -1087,7 +1096,8 @@ v4 todo:
[any #'(() #f)] [any #'(() #f)]
[[id ctc] #'((id) (ctc))] [[id ctc] #'((id) (ctc))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (and (syntax-parameter-value #'making-a-method) #t)]) [mtd? (and (syntax-parameter-value #'making-a-method) #t)]
[->m-ctc? (and (syntax-parameter-value #'method-contract?) #t)])
(let ([rng-underscores? (let ([rng-underscores?
(let ([is-underscore? (let ([is-underscore?
(λ (x) (λ (x)
@ -1128,7 +1138,7 @@ v4 todo:
#'body)])))]) #'body)])))])
(syntax-parameterize (syntax-parameterize
((making-a-method #f)) ((making-a-method #f))
(build-->d mtd? (build-->d mtd? ->m-ctc?
(list (λ (dom-params ...) (list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-doms)) ...) (parameterize-this this-parameter ... mandatory-doms)) ...)
(list (λ (dom-params ...) (list (λ (dom-params ...)
@ -1361,7 +1371,7 @@ v4 todo:
(define-struct unsupplied-arg ()) (define-struct unsupplied-arg ())
(define the-unsupplied-arg (make-unsupplied-arg)) (define the-unsupplied-arg (make-unsupplied-arg))
(define (build-->d mtd? (define (build-->d mtd? mctc?
mandatory-dom-ctcs optional-dom-ctcs mandatory-dom-ctcs optional-dom-ctcs
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
rest-ctc pre-cond range post-cond rest-ctc pre-cond range post-cond
@ -1372,7 +1382,7 @@ v4 todo:
(append mandatory-kwds optional-kwds) (append mandatory-kwds optional-kwds)
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs)) (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
(λ (x y) (keyword<? (car x) (car y))))]) (λ (x y) (keyword<? (car x) (car y))))])
(make-impersonator-->d mtd? (make-impersonator-->d mtd? mctc?
mandatory-dom-ctcs optional-dom-ctcs mandatory-dom-ctcs optional-dom-ctcs
(map cdr kwd/ctc-pairs) (map cdr kwd/ctc-pairs)
rest-ctc pre-cond range post-cond rest-ctc pre-cond range post-cond
@ -1382,7 +1392,8 @@ v4 todo:
name-wrapper))) name-wrapper)))
(define (->d-name ctc) (define (->d-name ctc)
(let* ([counting-id 'x] (let* ([name (if (base-->d-mctc? ctc) '->dm '->d)]
[counting-id 'x]
[ids '(x y z w)] [ids '(x y z w)]
[next-id [next-id
(λ () (λ ()
@ -1398,7 +1409,7 @@ v4 todo:
(begin0 (begin0
(string->symbol (format "~a~a" counting-id ids)) (string->symbol (format "~a~a" counting-id ids))
(set! ids (+ ids 1)))]))]) (set! ids (+ ids 1)))]))])
`(->d (,@(map (λ (x) `(,(next-id) ...)) (base-->d-mandatory-dom-ctcs ctc)) `(,name (,@(map (λ (x) `(,(next-id) ...)) (base-->d-mandatory-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-mandatory-keywords ctc)))) ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-mandatory-keywords ctc))))
(,@(map (λ (x) `(,(next-id) ...)) (base-->d-optional-dom-ctcs ctc)) (,@(map (λ (x) `(,(next-id) ...)) (base-->d-optional-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-optional-keywords ctc)))) ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (base-->d-optional-keywords ctc))))
@ -1447,6 +1458,7 @@ v4 todo:
;; 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 base-->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. (define-struct base-->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
mctc? ;; boolean; indicates if this contract was constructed with ->dm (from racket/class)
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))
@ -1570,13 +1582,15 @@ v4 todo:
(rng-proj-x ...) (rng-proj-x ...)
formals formals
body) ...) body) ...)
(map (λ (x) (parse-out-case stx x)) (syntax->list #'(cases ...)))]) (map (λ (x) (parse-out-case stx x)) (syntax->list #'(cases ...)))]
[mctc? (and (syntax-parameter-value #'method-contract?) #t)])
#`(syntax-parameterize #`(syntax-parameterize
((making-a-method #f)) ((making-a-method #f))
(build-case-> (list (list dom-proj ...) ...) (build-case-> (list (list dom-proj ...) ...)
(list rst-proj ...) (list rst-proj ...)
(list rng-proj ...) (list rng-proj ...)
'(spec ...) '(spec ...)
mctc?
(λ (chk (λ (chk
wrapper wrapper
blame blame
@ -1607,8 +1621,9 @@ v4 todo:
;; rst-ctcs : (listof contract) ;; rst-ctcs : (listof contract)
;; 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
;; mctc? : was created with case->m
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections ;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections
(define-struct base-case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)) (define-struct base-case-> (dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper))
(define (case->-proj wrapper) (define (case->-proj wrapper)
(λ (ctc) (λ (ctc)
@ -1645,7 +1660,7 @@ v4 todo:
(define (case->-name ctc) (define (case->-name ctc)
(apply (apply
build-compound-type-name build-compound-type-name
'case-> (if (base-case->-mctc? ctc) 'case->m 'case->)
(map (λ (dom rst range) (map (λ (dom rst range)
(apply (apply
build-compound-type-name build-compound-type-name
@ -1684,15 +1699,15 @@ v4 todo:
#:first-order case->-first-order #:first-order case->-first-order
#:stronger case->-stronger?)) #:stronger case->-stronger?))
(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper) (define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper)
(let ([dom-ctcs (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)] (let ([dom-ctcs (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)]
[rst-ctcs (map (λ (x) (and x (coerce-contract 'case-> x))) rst-ctcs)] [rst-ctcs (map (λ (x) (and x (coerce-contract 'case-> x))) rst-ctcs)]
[rng-ctcs (map (λ (l) (and l (map (λ (x) (coerce-contract 'case-> x)) l))) rng-ctcs)]) [rng-ctcs (map (λ (l) (and l (map (λ (x) (coerce-contract 'case-> x)) l))) rng-ctcs)])
(if (and (andmap (λ (l) (andmap chaperone-contract? l)) dom-ctcs) (if (and (andmap (λ (l) (andmap chaperone-contract? l)) dom-ctcs)
(andmap (λ (c) (or (not c) (chaperone-contract? c))) rst-ctcs) (andmap (λ (c) (or (not c) (chaperone-contract? c))) rst-ctcs)
(andmap (λ (l) (or (not l) (andmap chaperone-contract? l))) rng-ctcs)) (andmap (λ (l) (or (not l) (andmap chaperone-contract? l))) rng-ctcs))
(make-chaperone-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper) (make-chaperone-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper)
(make-impersonator-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)))) (make-impersonator-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper))))
(define (get-case->-dom-ctcs ctc) (define (get-case->-dom-ctcs ctc)
(apply append (apply append

10
collects/racket/private/class-internal.rkt
View File

@ -4,7 +4,7 @@
mzlib/etc mzlib/etc
racket/contract/base racket/contract/base
racket/contract/combinator racket/contract/combinator
(only-in racket/contract/private/arrow making-a-method) (only-in racket/contract/private/arrow making-a-method method-contract?)
racket/stxparam racket/stxparam
racket/unsafe/ops racket/unsafe/ops
"class-events.rkt" "class-events.rkt"
@ -2554,16 +2554,16 @@
;; Shorthand contracts that treat the implicit object argument as if it were ;; Shorthand contracts that treat the implicit object argument as if it were
;; contracted with any/c. ;; contracted with any/c.
(define-syntax-rule (->m . stx) (define-syntax-rule (->m . stx)
(syntax-parameterize ([making-a-method #t]) (-> . stx))) (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (-> . stx)))
(define-syntax-rule (->*m . stx) (define-syntax-rule (->*m . stx)
(syntax-parameterize ([making-a-method #t]) (->* . stx))) (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->* . stx)))
(define-syntax-rule (case->m . stx) (define-syntax-rule (case->m . stx)
(syntax-parameterize ([making-a-method #t]) (case-> . stx))) (syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx)))
(define-syntax-rule (->dm . stx) (define-syntax-rule (->dm . stx)
(syntax-parameterize ([making-a-method #'this-param]) (->d . stx))) (syntax-parameterize ([making-a-method #'this-param] [method-contract? #t]) (->d . stx)))
(define (class/c-check-first-order ctc cls fail) (define (class/c-check-first-order ctc cls fail)
(unless (class? cls) (unless (class? cls)

4
collects/tests/racket/contract-test.rktl
View File

@ -10546,6 +10546,10 @@ so that propagation occurs.
(test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal))
(test-name '(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)])) (test-name '(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)]))
(test-name '(class/c [m (->*m (integer?) (integer?) integer?)]) (class/c [m (->*m (integer?) (integer?) integer?)]))
(test-name '(class/c [m (case->m (-> integer? integer?) (-> integer? integer? integer?))])
(class/c [m (case->m (-> integer? integer?) (-> integer? integer? integer?))]))
(test-name '(class/c [m (->dm ((x ...)) () (y ...))]) (class/c [m (->dm ([d integer?]) () [r integer?])]))
(test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])]) (test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
c%/c)) c%/c))