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

Fix for optional keyword contracts used on make-keyword-procedure results.

Browse Source 
This fix should go into the 5.0 release.
This commit is contained in:
Stevie Strickland 2010-05-25 12:59:46 -04:00
parent e8fe67991e
commit 24c5a9aed8
2 changed files with 25 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -172,10 +172,7 @@ v4 todo:
(if (->-dom-rest/c ctc) (if (->-dom-rest/c ctc)
(procedure-accepts-and-more? x l) (procedure-accepts-and-more? x l)
(procedure-arity-includes? x l)) (procedure-arity-includes? x l))
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)]) (keywords-match (->-mandatory-kwds ctc) (->-optional-kwds ctc) x)
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
(->-mandatory-kwds ctc))))
#t)))) #t))))
#:stronger #:stronger
(λ (this that) (λ (this that)
@ -1541,9 +1538,13 @@ v4 todo:
(andmap (λ (kwd) (member kwd mandatory-kwds)) (andmap (λ (kwd) (member kwd mandatory-kwds))
proc-mandatory) proc-mandatory)
;; proc accepts (but does not require) ctc's optional keywords ;; proc accepts (but does not require) ctc's optional keywords
(andmap (λ (kwd) (and (member kwd proc-all) ;;
(not (member kwd proc-mandatory)))) ;; if proc-all is #f, then proc accepts all keywords and thus
optional-kwds)))) ;; this is triviably true (e.g. result of make-keyword-procedure)
(or (not proc-all)
(andmap (λ (kwd) (and (member kwd proc-all)
(not (member kwd proc-mandatory))))
optional-kwds)))))
(define (keyword-error-text mandatory-keywords optional-keywords) (define (keyword-error-text mandatory-keywords optional-keywords)
(define (format-keywords-error type kwds) (define (format-keywords-error type kwds)

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

@ -687,6 +687,23 @@
(λ () (values 1 2)) (λ () (values 1 2))
'pos 'neg))) 'pos 'neg)))
(test/spec-passed
'contract-arrow-star-optional24
'(let ()
(define (statement? s)
(and (string? s)
(> (string-length s) 3)))
(define statement/c (flat-contract statement?))
(define new-statement
(make-keyword-procedure
(λ (kws kw-args . statement)
(format "kws=~s kw-args=~s statement=~s" kws kw-args statement))))
(contract (->* (statement/c) (#:s string?) statement/c)
new-statement
'pos 'neg)))
(test/spec-passed (test/spec-passed
'contract-arrow-star-keyword-ordering 'contract-arrow-star-keyword-ordering
'((contract (->* (integer? #:x boolean?) (string? #:y char?) any) '((contract (->* (integer? #:x boolean?) (string? #:y char?) any)