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

adjust -> contract so that (-> any/c ... any) contracts are now

Browse Source 
flat contracts and using (-> any/c boolean?) uses predicate/c
without special intervention.

also, fix a bug in the opter contracts
This commit is contained in:
Robby Findler 2012-02-18 16:32:57 -06:00
parent 0e40cfcdc8
commit 2d76c3bcab
3 changed files with 66 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -363,7 +363,7 @@ v4 todo:
;; should we pass both the basic-lambda and the kwd-lambda?
(define (arity-checking-wrapper val blame basic-lambda kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd)
;; should not build this unless we are in the 'else' case (and maybe not at all
;; should not build this unless we are in the 'else' case (and maybe not at all)
(cond
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd))
@ -438,7 +438,13 @@ v4 todo:
;; func : the wrapper function maker. It accepts a procedure for
;; checking the first-order properties and the contracts
;; and it produces a wrapper-making function.
(define-struct base-> (pre post doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? mtd? func))
(define-struct base-> (pre post
doms/c optional-doms/c dom-rest/c
mandatory-kwds/c mandatory-kwds
optional-kwds/c optional-kwds
rngs/c rng-any?
mtd?
func))
(define ((->-proj wrapper) ctc)
(let* ([doms-proj (map contract-projection
@ -561,8 +567,6 @@ v4 todo:
((contract-struct-exercise c) v new-fuel)))])
(andmap gen-if-fun (base->-doms/c ctc) args))))
(define-struct (chaperone-> base->) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
@ -751,10 +755,6 @@ v4 todo:
;; the -> in the original input to this guy
(list (car (syntax-e stx)))
'()))))))
(define-syntax (-> stx)
#`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx)))
;
@ -2000,9 +2000,15 @@ v4 todo:
(λ (x) (send o m x)))))
(define predicate/c-private->ctc
(let ([predicate/c (-> any/c boolean?)])
predicate/c))
(define predicate/c-private->ctc
(let-syntax ([m (λ (stx)
;; we don't use -> directly here to avoid a circularity, since
;; (-> any/c boolean?) expands into the identifier -predicate/c
(syntax-case stx ()
[(_ arg)
#`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main #'arg))]))])
(let ([predicate/c (m (-> any/c boolean?))])
predicate/c)))
(struct predicate/c ()
#:property prop:chaperone-contract
@ -2020,3 +2026,16 @@ v4 todo:
#:stronger (λ (this that) (contract-struct-stronger? predicate/c-private->ctc that))))
(define -predicate/c (predicate/c))
(define-syntax (-> stx)
(syntax-case stx (any any/c boolean?)
[(_ any/c ... any)
;; special case the (-> any/c ... any) contracts to be first-order checks only
(with-syntax ([dom-len (- (length (syntax->list stx)) 2)]
[name (syntax->datum stx)])
#'(flat-named-contract 'name (λ (x) (and (procedure? x) (procedure-arity-includes? x dom-len #t)))))]
[(_ any/c boolean?)
;; special case (-> any/c boolean?) to use predicate/c
#'-predicate/c]
[_
#`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))]))

32
collects/racket/contract/private/opters.rkt
View File

@ -382,14 +382,17 @@
(check-procedure val #f dom-len 0 '() '() #| keywords |# blame)
(chaperone-procedure
val
(λ (dom-arg ...)
(values
(case-lambda
[(rng-arg ...)
(values next-rng ...)]
[args
(bad-number-of-results blame val rng-len args)])
next-dom ...))))))
(case-lambda
[(dom-arg ...)
(values
(case-lambda
[(rng-arg ...)
(values next-rng ...)]
[args
(bad-number-of-results blame val rng-len args)])
next-dom ...)]
[args
(bad-number-of-arguments blame val args dom-len)])))))
(append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs)
@ -439,8 +442,10 @@
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame)
(chaperone-procedure
val
(λ (dom-arg ...)
(values next-dom ...))))))
(case-lambda
[(dom-arg ...) (values next-dom ...)]
[args
(bad-number-of-arguments blame val args dom-len)])))))
lifts-doms
superlifts-doms
partials-doms
@ -477,3 +482,10 @@
(values next lift superlift partial flat _ stronger-ribs chaperone?)
(opt/unknown opt/i opt/info stx))))]))
(define (bad-number-of-arguments blame val args dom-len)
(define num-values (length args))
(raise-blame-error (blame-swap blame) val
"expected ~a argument~a, got ~a argument~a"
dom-len (if (= dom-len 1) "" "s")
num-values (if (= num-values 1) "" "s")))

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

@ -1131,6 +1131,18 @@
'contract-arrow-any3
'((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t))
(test/spec-passed
'contract-arrow-all-anys1
'((contract (-> any) (lambda () #f) 'pos 'neg)))
(test/pos-blame
'contract-arrow-all-anys2
'((contract (-> any) (lambda (x) #f) 'pos 'neg)))
(test/spec-passed
'contract-arrow-all-anys3
'((contract (-> any) (lambda ([x #f]) #f) 'pos 'neg)))
(test/spec-passed
'contract-arrow-all-kwds
'(contract (-> #:a string? string?)
@ -9572,6 +9584,8 @@ so that propagation occurs.
(test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t)
(test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t)
(ctest #t flat-contract? (-> any/c any/c any))
(ctest #t flat-contract? (and/c))
(ctest #t flat-contract? (and/c number? integer?))
(ctest #t flat-contract? (and/c (flat-contract number?)