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

implement the (-> any/c ... any) special case for the new -> contract combinator

Browse Source 
(new is being used in a relative sense here; it is the newer of the
two -> combinators; the old one is used currently only for ->m)
This commit is contained in:
Robby Findler 2016-01-01 12:21:23 -06:00
parent fd7b8b29ea
commit b24882fd18
6 changed files with 101 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkgs/racket-test/tests/racket/contract-rand-test.rkt
View File

@ -157,6 +157,7 @@
(λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11)))
(check-not-exn
(λ () (((test-contract-generation (-> (-> (>/c 10) (>/c 10))))) 11)))
(check-not-exn (λ () ((test-contract-generation (-> any/c any)) 1)))
(check-not-exn
(λ ()

5
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -71,6 +71,11 @@
(test-flat-contract #rx#".x." "axq" "x")
(test-flat-contract ''() '() #f)
(test-flat-contract '(-> any/c any/c any) (λ (x y) 1) (λ (x y z) 1))
(test-flat-contract '(->* (any/c any/c) any) (λ (x y) 1) (λ (x y z) 1))
(test-flat-contract '(->* () any) (λ () 1) (λ (x y z w) 1))
(test-flat-contract '(->* () () any) (λ () 1) (λ (x) 1))
(test-flat-contract '(if/c integer? even? list?) 2 3)
(test-flat-contract '(if/c integer? even? list?) '() #f)

4
pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -72,7 +72,9 @@
(-> integer? #:x integer? integer?)
(-> integer? #:x integer? integer?))
(ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2)))
(ctest #t contract-stronger? (-> any/c any/c any) (-> any/c any/c any))
(ctest #f contract-stronger? (-> any/c any/c any/c any) (-> any/c any/c any))
(let ([c (contract-eval '(->* () () any))])
(test #t (contract-eval 'contract-stronger?) c c))
(let ([c (contract-eval '(->d () () any))])

110
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -15,7 +15,9 @@
(provide ->2 ->*2
dynamic->*
(for-syntax ->2-handled?
->2-arity-check-only->?
->*2-handled?
->2*-arity-check-only->?
->-valid-app-shapes
->*-valid-app-shapes)
(rename-out [-predicate/c predicate/c]))
@ -25,11 +27,13 @@
[(_ args ...)
(syntax-parameter-value #'arrow:making-a-method)
#f]
[(_ any/c ... any)
;; should turn into a flat contract
#f]
[_ #t]))
(define-for-syntax (->2-arity-check-only->? stx)
(syntax-case stx (any any/c)
[(_ any/c ... any) (- (length (syntax->list stx)) 2)]
[_ #f]))
(define-for-syntax (->*2-handled? stx)
(syntax-case stx (any values any/c)
[(_ args ...)
@ -37,6 +41,12 @@
#f]
[_ #t]))
(define-for-syntax (->2*-arity-check-only->? stx)
(syntax-case stx (any any/c)
[(_ (any/c ...) any) (length (syntax->list (cadr (syntax->list stx))))]
[(_ (any/c ...) () any) (length (syntax->list (cadr (syntax->list stx))))]
[_ #f]))
(define-for-syntax popular-keys
;; of the 8417 contracts that get compiled during
;; 'raco setup' of the current tree, these are all
@ -532,6 +542,9 @@
[(_ args ...)
(not (->2-handled? stx))
#'(arrow:-> args ...)]
[(_ args ...)
(->2-arity-check-only->? stx)
#`(build-arity-check-only-> #,(->2-arity-check-only->? stx))]
[(_ args ... rng)
(let ()
(define this-> (gensym 'this->))
@ -649,6 +662,10 @@
(define-syntax (->*2 stx)
(cond
[(->2*-arity-check-only->? stx)
=>
(λ (n)
#`(build-arity-check-only-> #,n))]
[(->*2-handled? stx)
(define this->* (gensym 'this->*))
(define-values (man-dom man-dom-kwds man-lets
@ -809,6 +826,18 @@
plus-one-arity-function
chaperone-constructor)]))
(define (build-arity-check-only-> n)
(make-arity-check-only-> n
(build-list n (λ (_) any/c))
'() #f #f #f #f
(λ args
(error 'arity-check-only->-plus-one-arity-function
"this function should not be called ~s" args))
(λ args
(error 'arity-check-only->-chaperone-constructor
"this function should not be called ~s" args))
n))
(define (dynamic->* #:mandatory-domain-contracts [mandatory-domain-contracts '()]
#:optional-domain-contracts [optional-domain-contracts '()]
#:mandatory-keywords [unsorted-mandatory-keywords '()]
@ -1187,34 +1216,63 @@
(define cblame (cthis blame))
(λ (val)
((cblame val) #f))))
#:stronger
(λ (this that)
(and (base->? that)
(= (length (base->-doms that))
(length (base->-doms this)))
(= (base->-min-arity this) (base->-min-arity that))
(andmap contract-stronger? (base->-doms that) (base->-doms this))
(= (length (base->-kwd-infos this))
(length (base->-kwd-infos that)))
(for/and ([this-kwd-info (base->-kwd-infos this)]
[that-kwd-info (base->-kwd-infos that)])
(and (equal? (kwd-info-kwd this-kwd-info)
(kwd-info-kwd that-kwd-info))
(contract-stronger? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(if (base->-rngs this)
(and (base->-rngs that)
(andmap contract-stronger? (base->-rngs this) (base->-rngs that)))
(not (base->-rngs that)))
(not (base->-pre? this))
(not (base->-pre? that))
(not (base->-post? this))
(not (base->-post? that))))
#:stronger ->-stronger
#:generate ->-generate
#:exercise ->-exercise
#:val-first-projection val-first-proj
#:late-neg-projection late-neg-proj))
(define (->-stronger this that)
(and (base->? that)
(= (length (base->-doms that))
(length (base->-doms this)))
(= (base->-min-arity this) (base->-min-arity that))
(andmap contract-stronger? (base->-doms that) (base->-doms this))
(= (length (base->-kwd-infos this))
(length (base->-kwd-infos that)))
(for/and ([this-kwd-info (base->-kwd-infos this)]
[that-kwd-info (base->-kwd-infos that)])
(and (equal? (kwd-info-kwd this-kwd-info)
(kwd-info-kwd that-kwd-info))
(contract-stronger? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(if (base->-rngs this)
(and (base->-rngs that)
(andmap contract-stronger? (base->-rngs this) (base->-rngs that)))
(not (base->-rngs that)))
(not (base->-pre? this))
(not (base->-pre? that))
(not (base->-post? this))
(not (base->-post? that))))
(define-struct (arity-check-only-> base->) (arity)
#:property
prop:flat-contract
(build-flat-contract-property
#:name base->-name
#:first-order
(λ (ctc)
(define arity (arity-check-only->-arity ctc))
(λ (val)
(arrow:procedure-arity-includes?/no-kwds val arity)))
#:late-neg-projection
(λ (ctc)
(define arity (arity-check-only->-arity ctc))
(λ (blame)
(λ (val neg-party)
(if (arrow:procedure-arity-includes?/no-kwds val arity)
val
(raise-blame-error
blame #:missing-party neg-party val
'(expected: "a procedure that accepts ~a non-keyword argument~a"
given: "~e")
arity
(if (= arity 1) "" "s")
val)))))
#:stronger ->-stronger
#:generate ->-generate
#:exercise ->-exercise))
(define-struct (-> base->) ()
#:property
prop:chaperone-contract

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

@ -41,7 +41,8 @@
blame-add-range-context
blame-add-nth-arg-context
raise-no-keywords-arg
raise-wrong-number-of-args-error)
raise-wrong-number-of-args-error
procedure-arity-includes?/no-kwds)
(define-syntax-parameter making-a-method #f)
(define-syntax-parameter method-contract? #f)
@ -1911,6 +1912,8 @@
[(_ any/c ... any)
(not (syntax-parameter-value #'making-a-method))
;; special case the (-> any/c ... any) contracts to be first-order checks only
;; this is now implemented by ->2 so we should get here only when we're
;; building an ->m contract
(let ([dom-len (- (length (syntax->list stx)) 2)])
#`(flat-named-contract
'(-> #,@(build-list dom-len (λ (x) 'any/c)) any)

6
racket/collects/racket/contract/private/provide.rkt
View File

@ -276,10 +276,12 @@
(define-values (arrow? the-valid-app-shapes)
(syntax-case ctrct (->2 ->*2 ->i)
[(->2 . _)
(->2-handled? ctrct)
(and (->2-handled? ctrct)
(not (->2-arity-check-only->? ctrct)))
(values #t (->-valid-app-shapes ctrct))]
[(->*2 . _)
(values (->*2-handled? ctrct)
(values (and (->*2-handled? ctrct)
(not (->2*-arity-check-only->? ctrct)))
(->*-valid-app-shapes ctrct))]
[(->i . _) (values #t (->i-valid-app-shapes ctrct))]
[_ (values #f #f)]))