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

implement predicate/c for the more complex arrow contract protocol

Browse Source 
So now (-> any/c integer?) will avoid the chaperone wrapper when the
function is a struct predicate while simultaneously supporting the
"extra argument neg party" protocol
This commit is contained in:
Robby Findler 2015-10-28 20:22:16 -05:00
parent d17cc6039b
commit 3f20803679
9 changed files with 242 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt
View File

@ -270,4 +270,19 @@
(->* (any/c) (#:kw any/c) any)
(λ (x #:kw [kw 0]) x))
'neg 42)
42))
42)
(test/pos-blame
'->neg-party23
'((neg-party-fn
(-> any/c boolean?)
(λ (x) 1))
'neg 1))
(test/spec-passed/result
'->neg-party24
'((neg-party-fn
(-> any/c boolean?)
(λ (x) #t))
'neg 1)
#t))

24
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -353,6 +353,30 @@
(test/spec-passed
'predicate/c4
'((contract predicate/c (λ (x) #t) 'pos 'neg) 12))
(test/spec-passed/result
'predicate/c5
'(let ()
(struct s ())
(eq? (contract (-> any/c boolean?) s? 'pos 'neg) s?))
#t)
(test/spec-passed/result
'predicate/c6
'(let ()
(struct s ())
(eq? (contract predicate/c s? 'pos 'neg) s?))
#t)
(test/pos-blame
'predicate/c7
'(contract (-> any/c boolean?) 1 'pos 'neg))
(test/pos-blame
'predicate/c8
'(contract (-> any/c boolean?) (λ (x y) 1) 'pos 'neg))
(test/pos-blame
'predicate/c9
'((contract (-> any/c boolean?) (λ (x) 1) 'pos 'neg) 12))
(test/spec-passed
'predicate/c10
'((contract (-> any/c boolean?) (λ (x) #t) 'pos 'neg) 12))
;; this test ensures that no contract wrappers
;; are created for struct predicates

2
pkgs/racket-test/tests/racket/contract/name.rkt
View File

@ -47,6 +47,8 @@
(->* (integer? boolean?) () (values char? any/c)))
(test-name '(-> integer? boolean? any) (->* (integer? boolean?) () any))
(test-name '(-> integer? boolean? #:x string? any) (-> integer? #:x string? boolean? any))
(test-name '(-> any/c boolean?) (-> any/c boolean?))
(test-name 'predicate/c predicate/c)
(test-name '(->* (integer?) (string?) #:rest any/c (values char? any/c))
(->* (integer?) (string?) #:rest any/c (values char? any/c)))

1
racket/collects/racket/contract/base.rkt
View File

@ -35,6 +35,7 @@
-> ->*)
(rename-out [->2 ->] [->*2 ->*])
dynamic->*
predicate/c
(all-from-out "private/arr-i.rkt"
"private/box.rkt"

31
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -406,20 +406,23 @@
(define (successfully-got-the-right-kind-of-function val neg-party)
(define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args))
(if post?
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:application-mark (cons arrow:contract-key
;; is this right?
partial-ranges))))
(cond
[chap/imp-func
(if post?
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:application-mark (cons arrow:contract-key
;; is this right?
partial-ranges)))]
[else val]))
(cond
[late-neg?

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

@ -18,10 +18,11 @@
(for-syntax ->2-handled?
->*2-handled?
->-valid-app-shapes
->*-valid-app-shapes))
->*-valid-app-shapes)
(rename-out [-predicate/c predicate/c]))
(define-for-syntax (->2-handled? stx)
(syntax-case stx (any values any/c)
(syntax-case stx (any values any/c boolean?)
[(_ args ...)
(syntax-parameter-value #'arrow:making-a-method)
#f]
@ -781,6 +782,18 @@
(flat-contract? (car rngs))
(eq? void? (flat-contract-predicate (car rngs))))
->void-contract]
[(and (pair? regular-doms)
(null? (cdr regular-doms))
(any/c? (car regular-doms))
(null? kwd-infos)
(not rest-ctc)
(not pre-cond)
(not post-cond)
(pair? rngs)
(null? (cdr rngs))
(flat-contract? (car rngs))
(eq? boolean? (flat-contract-predicate (car rngs))))
any/c->boolean-contract]
[(and (andmap chaperone-contract? regular-doms)
(andmap (λ (x) (chaperone-contract? (kwd-info-ctc x))) kwd-infos)
(andmap chaperone-contract? (or rngs '())))
@ -1061,62 +1074,65 @@
(λ (fuel) (values void '()))]))
(define (base->-name ctc)
(define rngs (base->-rngs ctc))
(define rng-sexp
(cond
[(not rngs) 'any]
[(= 1 (length rngs))
(contract-name (car rngs))]
[else
`(values ,@(map contract-name rngs))]))
(cond
[(and (andmap kwd-info-mandatory? (base->-kwd-infos ctc))
(= (base->-min-arity ctc)
(length (base->-doms ctc)))
(not (base->-rest ctc))
(not (base->-pre? ctc))
(not (base->-post? ctc)))
`(-> ,@(map contract-name (base->-doms ctc))
,@(apply
append
(for/list ([kwd-info (base->-kwd-infos ctc)])
(list (kwd-info-kwd kwd-info)
(contract-name (kwd-info-ctc kwd-info)))))
,rng-sexp)]
[(predicate/c? ctc) 'predicate/c]
[else
(define (take l n) (reverse (list-tail (reverse l) (- (length l) n))))
(define mandatory-args
`(,@(map contract-name (take (base->-doms ctc) (base->-min-arity ctc)))
,@(apply
append
(for/list ([kwd-info (base->-kwd-infos ctc)]
#:when (kwd-info-mandatory? kwd-info))
(list (kwd-info-kwd kwd-info)
(contract-name (kwd-info-ctc kwd-info)))))))
(define optional-args
`(,@(map contract-name (list-tail (base->-doms ctc) (base->-min-arity ctc)))
,@(apply
append
(for/list ([kwd-info (base->-kwd-infos ctc)]
#:when (not (kwd-info-mandatory? kwd-info)))
(list (kwd-info-kwd kwd-info)
(contract-name (kwd-info-ctc kwd-info)))))))
`(->* ,mandatory-args
,@(if (null? optional-args)
'()
(list optional-args))
,@(if (base->-rest ctc)
(list '#:rest (contract-name (base->-rest ctc)))
(list))
,@(if (base->-pre? ctc)
(list '#:pre '...)
(list))
,rng-sexp
,@(if (base->-post? ctc)
(list '#:post '...)
(list)))]))
(define rngs (base->-rngs ctc))
(define rng-sexp
(cond
[(not rngs) 'any]
[(= 1 (length rngs))
(contract-name (car rngs))]
[else
`(values ,@(map contract-name rngs))]))
(cond
[(and (andmap kwd-info-mandatory? (base->-kwd-infos ctc))
(= (base->-min-arity ctc)
(length (base->-doms ctc)))
(not (base->-rest ctc))
(not (base->-pre? ctc))
(not (base->-post? ctc)))
`(-> ,@(map contract-name (base->-doms ctc))
,@(apply
append
(for/list ([kwd-info (base->-kwd-infos ctc)])
(list (kwd-info-kwd kwd-info)
(contract-name (kwd-info-ctc kwd-info)))))
,rng-sexp)]
[else
(define (take l n) (reverse (list-tail (reverse l) (- (length l) n))))
(define mandatory-args
`(,@(map contract-name (take (base->-doms ctc) (base->-min-arity ctc)))
,@(apply
append
(for/list ([kwd-info (base->-kwd-infos ctc)]
#:when (kwd-info-mandatory? kwd-info))
(list (kwd-info-kwd kwd-info)
(contract-name (kwd-info-ctc kwd-info)))))))
(define optional-args
`(,@(map contract-name (list-tail (base->-doms ctc) (base->-min-arity ctc)))
,@(apply
append
(for/list ([kwd-info (base->-kwd-infos ctc)]
#:when (not (kwd-info-mandatory? kwd-info)))
(list (kwd-info-kwd kwd-info)
(contract-name (kwd-info-ctc kwd-info)))))))
`(->* ,mandatory-args
,@(if (null? optional-args)
'()
(list optional-args))
,@(if (base->-rest ctc)
(list '#:rest (contract-name (base->-rest ctc)))
(list))
,@(if (base->-pre? ctc)
(list '#:pre '...)
(list))
,rng-sexp
,@(if (base->-post? ctc)
(list '#:post '...)
(list)))])]))
(define ((->-first-order ctc) x)
(define l (base->-min-arity ctc))
@ -1204,6 +1220,11 @@
prop:chaperone-contract
(make-property build-chaperone-contract-property chaperone-procedure))
(define-struct (predicate/c base->) ()
#:property
prop:chaperone-contract
(make-property build-chaperone-contract-property chaperone-procedure))
(define-struct (impersonator-> base->) ()
#:property
prop:contract
@ -1212,8 +1233,11 @@
(define ->void-contract
(let-syntax ([get-chaperone-constructor
(λ (_)
;; relies on the popular key (0 0 () () #f 1) appearing first
(define ids (list-ref popular-key-ids 0))
(define desired-key '(0 0 () () #f 1))
(define expected-index 0)
(unless (equal? desired-key (list-ref popular-keys expected-index))
(error '->void-contract "expected the 0th key to be ~s" desired-key))
(define ids (list-ref popular-key-ids expected-index))
(list-ref ids 1))])
(make--> 0 '() '() #f #f
(list (coerce-contract 'whatever void?))
@ -1232,3 +1256,51 @@
[args
(wrong-number-of-results-blame blame neg-party f args 1)]))))
(get-chaperone-constructor))))
(define (mk-any/c->boolean-contract constructor)
(define (rng-checker f blame neg-party)
(case-lambda
[(rng)
(if (boolean? rng)
rng
(raise-blame-error blame #:missing-party neg-party rng
'(expected: "boolean?" given: "~e")
rng))]
[args
(wrong-number-of-results-blame blame neg-party f args 1)]))
(constructor 1 (list any/c) '() #f #f
(list (coerce-contract 'whatever boolean?))
#f
(λ (blame f _ignored-dom-contract _ignored-rng-contract)
(λ (neg-party argument)
(call-with-values
(λ () (f argument))
(rng-checker f blame neg-party))))
(λ (blame f neg-party _ignored-dom-contract _ignored-rng-contract)
(unless (procedure? f)
(raise-blame-error
blame #:missing-party neg-party f
'(expected: "a procedure" given: "~e")
f))
(unless (procedure-arity-includes? f 1)
(raise-blame-error
blame #:missing-party neg-party f
'(expected: "a procedure that accepts 1 non-keyword argument"
given: "~e")
f))
(cond
[(struct-predicate-procedure? f) #f]
[(equal? (procedure-arity f) 1)
(λ (arg)
(values (rng-checker f blame neg-party) arg))]
[(procedure-arity-includes? f 1)
(make-keyword-procedure
(λ (kwds kwd-args . other)
(unless (null? kwds)
(arrow:raise-no-keywords-arg blame f kwds))
(unless (= 1 (length other))
(arrow:raise-wrong-number-of-args-error blame f (length other) 1 1 1))
(values (rng-checker f blame neg-party) '() (car other))))]))))
(define -predicate/c (mk-any/c->boolean-contract predicate/c))
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->))

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

@ -21,7 +21,6 @@
base->-doms/c
unconstrained-domain->
the-unsupplied-arg
(rename-out [-predicate/c predicate/c])
unsupplied-arg?
making-a-method
method-contract?
@ -40,7 +39,9 @@
arity-checking-wrapper
unspecified-dom
blame-add-range-context
blame-add-nth-arg-context)
blame-add-nth-arg-context
raise-no-keywords-arg
raise-wrong-number-of-args-error)
(define-syntax-parameter making-a-method #f)
(define-syntax-parameter method-contract? #f)
@ -394,16 +395,6 @@
basic-lambda
kwd-lambda)]
[else
(define arity-string
(if max-arity
(cond
[(= min-method-arity max-method-arity)
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))]
[(= (+ min-method-arity 1) max-method-arity)
(format "~a or ~a non-keyword arguments" min-method-arity max-method-arity)]
[else
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)])
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
(define-values (vr va) (procedure-keywords val))
(define all-kwds (append req-kwd opt-kwd))
(define (valid-number-of-args? args)
@ -413,31 +404,16 @@
(define kwd-checker
(if (and (null? req-kwd) (null? opt-kwd))
(λ (kwds kwd-args . args)
(raise-blame-error (blame-swap blame) val
(list 'expected:
"no keywords"
'given:
(apply
string-append
(let loop ([kwds kwds])
(cond
[(null? kwds) '()]
[(null? (cdr kwds))
(list "#:" (keyword->string (car kwds)))]
[else
(list* "#:"
(keyword->string (car kwds))
" "
(loop (cdr kwds)))]))))))
(raise-no-keywords-arg blame val kwds))
(λ (kwds kwd-args . args)
(with-continuation-mark
contract-continuation-mark-key blame
(let ()
(define args-len (length args))
(unless (valid-number-of-args? args)
(raise-blame-error (blame-swap blame) val
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
(raise-wrong-number-of-args-error
blame val
args-len max-arity min-method-arity max-method-arity))
;; these two for loops are doing O(n^2) work that could be linear
;; (since the keyword lists are sorted)
@ -460,9 +436,9 @@
(let ()
(unless (valid-number-of-args? args)
(define args-len (length args))
(raise-blame-error (blame-swap blame) val
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
(raise-wrong-number-of-args-error
blame val
args-len max-arity min-method-arity max-method-arity))
(apply basic-lambda args))))
(λ args
(raise-blame-error (blame-swap blame) val
@ -472,6 +448,41 @@
(make-keyword-procedure kwd-checker basic-checker-name)
basic-checker-name)]))
(define (raise-wrong-number-of-args-error
blame val
args-len max-arity min-method-arity max-method-arity)
(define arity-string
(if max-arity
(cond
[(= min-method-arity max-method-arity)
(format "~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))]
[(= (+ min-method-arity 1) max-method-arity)
(format "~a or ~a non-keyword arguments" min-method-arity max-method-arity)]
[else
(format "~a to ~a non-keyword arguments" min-method-arity max-method-arity)])
(format "at least ~a non-keyword argument~a" min-method-arity (if (= min-method-arity 1) "" "s"))))
(raise-blame-error (blame-swap blame) val
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
(define (raise-no-keywords-arg blame val given-kwds)
(raise-blame-error (blame-swap blame) val
(list 'expected:
"no keywords"
'given:
(apply
string-append
(let loop ([kwds given-kwds])
(cond
[(null? kwds) '()]
[(null? (cdr kwds))
(list "#:" (keyword->string (car kwds)))]
[else
(list* "#:"
(keyword->string (car kwds))
" "
(loop (cdr kwds)))]))))))
;; pre : (or/c #f (-> any)) -- checks the pre-condition, if there is one.
;; post : (or/c #f (-> any)) -- checks the post-condition, if there is one.
;; doms : (listof contract)
@ -1822,34 +1833,6 @@
(λ (x) (send o m x)))))
(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:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (let ([pc (contract-struct-projection predicate/c-private->ctc)])
(λ (ctc)
(λ (blame)
(let ([proj (pc blame)])
(λ (val)
(if (struct-predicate-procedure? val)
val
(proj val)))))))
#:name (lambda (ctc) 'predicate/c)
#:first-order (let ([f (contract-struct-first-order predicate/c-private->ctc)]) (λ (ctc) f))
#: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)
@ -1860,10 +1843,6 @@
'(-> #,@(build-list dom-len (λ (x) 'any/c)) any)
(λ (x)
(procedure-arity-includes?/no-kwds x #,dom-len))))]
[(_ any/c boolean?)
;; special case (-> any/c boolean?) to use predicate/c
(not (syntax-parameter-value #'making-a-method))
#'-predicate/c]
[_
#`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))]))

2
racket/collects/racket/contract/private/misc.rkt
View File

@ -32,7 +32,7 @@
parameter/c
procedure-arity-includes/c
any/c
any/c any/c?
any
none/c
make-none/c

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

@ -434,7 +434,7 @@
[(_ content) (opt/listof-ctc #'content #t opt/i opt/info)]))
(define-for-syntax (predicate/c-optres opt/info)
(define-for-syntax (predicate/c-optres opt/info has-name-predicate/c?)
(build-optres
#:exp
(with-syntax ((val (opt/info-val opt/info))
@ -472,7 +472,9 @@
#:opt #f
#:stronger-ribs null
#:chaperone #t
#:name #''predicate/c))
#:name (if has-name-predicate/c?
#''predicate/c
#''(-> any/c boolean?))))
;;
;; arrow opter
@ -698,7 +700,7 @@
#:chaperone #t
#:name #`'(-> #,@(build-list (syntax-e #'n) (λ (x) 'any/c)) any)))]
[(_ any/c boolean?)
(predicate/c-optres opt/info)]
(predicate/c-optres opt/info #f)]
[(_ dom ... (values rng ...))
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
@ -737,7 +739,7 @@
(define opt->/c-cm-key (gensym 'opt->/c-cm-key))
(define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info))
(define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t))
(define (handle-non-exact-procedure val dom-len blame exact-proc)
(check-procedure val #f dom-len 0 '() '() blame)