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

Move some contract helpers.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-05-20 13:47:38 -05:00
parent 26663bb2d7
commit a1ca38f30e
3 changed files with 58 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
racket/collects/racket/contract/private/arrow-common.rkt
View File

@ -12,6 +12,7 @@
blame-add-nth-arg-context blame-add-nth-arg-context
check-procedure check-procedure/more check-procedure check-procedure/more
procedure-accepts-and-more? procedure-accepts-and-more?
procedure-arity-exactly/no-kwds
keywords-match keywords-match
(for-syntax check-tail-contract) (for-syntax check-tail-contract)
matches-arity-exactly? matches-arity-exactly?
@ -21,7 +22,25 @@
tail-contract-key tail-marks-match? tail-contract-key tail-marks-match?
bad-number-of-results bad-number-of-results
the-unsupplied-arg unsupplied-arg? the-unsupplied-arg unsupplied-arg?
values/drop) values/drop
(struct-out base->)
raise-wrong-number-of-args-error)
;; min-arity : nat
;; doms : (listof contract?)[len >= min-arity]
;; includes optional arguments in list @ end
;; kwd-infos : (listof kwd-info)
;; rest : (or/c #f contract?)
;; pre? : (or/c #f 'pre 'pre/desc)
;; rngs : (listof contract?)
;; post? : (or/c #f 'post 'post/desc)
;; plus-one-arity-function : procedure? -- special, +1 argument wrapper that accepts neg-party
;; chaperone-constructor ; procedure? -- function that builds a projection tailored to this arrow
;; method? : boolean?
(define-struct base-> (min-arity doms kwd-infos rest pre? rngs post?
plus-one-arity-function chaperone-constructor
method?)
#:property prop:custom-write custom-write-property-proc)
(define-struct unsupplied-arg ()) (define-struct unsupplied-arg ())
(define the-unsupplied-arg (make-unsupplied-arg)) (define the-unsupplied-arg (make-unsupplied-arg))
@ -243,6 +262,13 @@
[else [else
passes?])) passes?]))
(define (procedure-arity-exactly/no-kwds val min-arity)
(and (procedure? val)
(equal? (procedure-arity val) min-arity)
(let-values ([(man opt) (procedure-keywords val)])
(and (null? man)
(null? opt)))))
(define (procedure-arity-includes?/optionals f base optionals) (define (procedure-arity-includes?/optionals f base optionals)
(cond (cond
[(zero? optionals) (procedure-arity-includes? f base #t)] [(zero? optionals) (procedure-arity-includes? f base #t)]
@ -333,6 +359,26 @@
(blame-add-context blame (blame-add-context blame
(format "the ~a argument of" (n->th n)))) (format "the ~a argument of" (n->th n))))
(define (raise-wrong-number-of-args-error
blame #:missing-party [missing-party #f] val
args-len pre-min-arity pre-max-arity method?)
(define min-arity ((if method? sub1 values) pre-min-arity))
(define max-arity ((if method? sub1 values) pre-max-arity))
(define arity-string
(if max-arity
(cond
[(= min-arity max-arity)
(format "~a non-keyword argument~a" min-arity (if (= min-arity 1) "" "s"))]
[(= (+ min-arity 1) max-arity)
(format "~a or ~a non-keyword arguments" min-arity max-arity)]
[else
(format "~a to ~a non-keyword arguments" min-arity max-arity)])
(format "at least ~a non-keyword argument~a" min-arity (if (= min-arity 1) "" "s"))))
(raise-blame-error (blame-swap blame) val
#:missing-party missing-party
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
;; timing & size tests ;; timing & size tests
#; #;

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

@ -15,12 +15,10 @@
unsafe-impersonate-procedure)) unsafe-impersonate-procedure))
(provide (for-syntax build-chaperone-constructor/real) (provide (for-syntax build-chaperone-constructor/real)
procedure-arity-exactly/no-kwds
->-proj ->-proj
check-pre-cond check-pre-cond
check-post-cond check-post-cond
pre-post/desc-result->string pre-post/desc-result->string
raise-wrong-number-of-args-error
arity-checking-wrapper) arity-checking-wrapper)
(define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx)) (define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx))
@ -474,7 +472,7 @@
(let () (let ()
(define args-len (length args)) (define args-len (length args))
(unless (valid-number-of-args? args) (unless (valid-number-of-args? args)
(raise-wrong-number-of-args-error (arrow:raise-wrong-number-of-args-error
blame #:missing-party neg-party val blame #:missing-party neg-party val
args-len min-arity max-arity method?)) args-len min-arity max-arity method?))
@ -500,7 +498,7 @@
(let () (let ()
(unless (valid-number-of-args? args) (unless (valid-number-of-args? args)
(define args-len (length args)) (define args-len (length args))
(raise-wrong-number-of-args-error (arrow:raise-wrong-number-of-args-error
blame #:missing-party neg-party val blame #:missing-party neg-party val
args-len min-arity max-arity method?)) args-len min-arity max-arity method?))
(apply basic-lambda args)))) (apply basic-lambda args))))
@ -522,26 +520,6 @@
(struct-predicate-procedure? f) (struct-predicate-procedure? f)
(struct-mutator-procedure? f))) (struct-mutator-procedure? f)))
(define (raise-wrong-number-of-args-error
blame #:missing-party [missing-party #f] val
args-len pre-min-arity pre-max-arity method?)
(define min-arity ((if method? sub1 values) pre-min-arity))
(define max-arity ((if method? sub1 values) pre-max-arity))
(define arity-string
(if max-arity
(cond
[(= min-arity max-arity)
(format "~a non-keyword argument~a" min-arity (if (= min-arity 1) "" "s"))]
[(= (+ min-arity 1) max-arity)
(format "~a or ~a non-keyword arguments" min-arity max-arity)]
[else
(format "~a to ~a non-keyword arguments" min-arity max-arity)])
(format "at least ~a non-keyword argument~a" min-arity (if (= min-arity 1) "" "s"))))
(raise-blame-error (blame-swap blame) val
#:missing-party missing-party
'(received: "~a argument~a" expected: "~a")
args-len (if (= args-len 1) "" "s") arity-string))
(define (maybe-cons-kwd c x r neg-party) (define (maybe-cons-kwd c x r neg-party)
(if (eq? arrow:unspecified-dom x) (if (eq? arrow:unspecified-dom x)
r r
@ -652,7 +630,7 @@
(if okay-to-do-only-arity-check? (if okay-to-do-only-arity-check?
(λ (val neg-party) (λ (val neg-party)
(cond (cond
[(procedure-arity-exactly/no-kwds val min-arity) val] [(arrow:procedure-arity-exactly/no-kwds val min-arity) val]
[else (arrow-higher-order:lnp val neg-party)])) [else (arrow-higher-order:lnp val neg-party)]))
arrow-higher-order:lnp)] arrow-higher-order:lnp)]
[else [else
@ -677,7 +655,7 @@
(if okay-to-do-only-arity-check? (if okay-to-do-only-arity-check?
(λ (val) (λ (val)
(cond (cond
[(procedure-arity-exactly/no-kwds val min-arity) [(arrow:procedure-arity-exactly/no-kwds val min-arity)
(define-values (normal-proc proc-with-no-result-checking expected-number-of-results) (define-values (normal-proc proc-with-no-result-checking expected-number-of-results)
(apply plus-one-arity-function orig-blame val plus-one-constructor-args)) (apply plus-one-arity-function orig-blame val plus-one-constructor-args))
(wrapped-extra-arg-arrow (wrapped-extra-arg-arrow
@ -685,10 +663,3 @@
normal-proc)] normal-proc)]
[else (arrow-higher-order:vfp val)])) [else (arrow-higher-order:vfp val)]))
arrow-higher-order:vfp)]))) arrow-higher-order:vfp)])))
(define (procedure-arity-exactly/no-kwds val min-arity)
(and (procedure? val)
(equal? (procedure-arity val) min-arity)
(let-values ([(man opt) (procedure-keywords val)])
(and (null? man)
(null? opt)))))

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

@ -8,10 +8,10 @@
"prop.rkt" "prop.rkt"
"guts.rkt" "guts.rkt"
"generate.rkt" "generate.rkt"
"arrow-common.rkt"
"arrow-higher-order.rkt" "arrow-higher-order.rkt"
"list.rkt" "list.rkt"
racket/stxparam racket/stxparam)
(prefix-in arrow: "arrow-common.rkt"))
(provide (rename-out [->/c ->]) ->* (provide (rename-out [->/c ->]) ->*
(for-syntax ->-internal ->*-internal) ; for ->m and ->*m (for-syntax ->-internal ->*-internal) ; for ->m and ->*m
@ -454,7 +454,7 @@
(define results (call-with-values mk-call list)) (define results (call-with-values mk-call list))
(define rng-len (length rngs)) (define rng-len (length rngs))
(unless (= (length results) rng-len) (unless (= (length results) rng-len)
(arrow:bad-number-of-results complete-blame f rng-len results)) (bad-number-of-results complete-blame f rng-len results))
(when post (check-post-cond post blame neg-party complete-blame f)) (when post (check-post-cond post blame neg-party complete-blame f))
(apply (apply
values values
@ -1126,7 +1126,7 @@
(loop (cdr args) (cdr projs)))]))) (loop (cdr args) (cdr projs)))])))
(define (result-checker . results) (define (result-checker . results)
(unless (= rng-len (length results)) (unless (= rng-len (length results))
(arrow:bad-number-of-results (blame-add-missing-party blame neg-party) (bad-number-of-results (blame-add-missing-party blame neg-party)
f rng-len results)) f rng-len results))
(apply (apply
values values
@ -1160,22 +1160,6 @@
build-chaperone-constructor build-chaperone-constructor
#f)) ; not a method contract #f)) ; not a method contract
;; min-arity : nat
;; doms : (listof contract?)[len >= min-arity]
;; includes optional arguments in list @ end
;; kwd-infos : (listof kwd-info)
;; rest : (or/c #f contract?)
;; pre? : (or/c #f 'pre 'pre/desc)
;; rngs : (listof contract?)
;; post? : (or/c #f 'post 'post/desc)
;; plus-one-arity-function : procedure? -- special, +1 argument wrapper that accepts neg-party
;; chaperone-constructor ; procedure? -- function that builds a projection tailored to this arrow
;; method? : boolean?
(define-struct base-> (min-arity doms kwd-infos rest pre? rngs post?
plus-one-arity-function chaperone-constructor
method?)
#:property prop:custom-write custom-write-property-proc)
(define (->-generate ctc) (define (->-generate ctc)
(cond (cond
[(and (equal? (length (base->-doms ctc)) [(and (equal? (length (base->-doms ctc))
@ -1366,9 +1350,9 @@
(kwd-info-kwd kwd-info))) (kwd-info-kwd kwd-info)))
(and (procedure? x) (and (procedure? x)
(if (base->-rest ctc) (if (base->-rest ctc)
(arrow:procedure-accepts-and-more? x l) (procedure-accepts-and-more? x l)
(procedure-arity-includes? x l #t)) (procedure-arity-includes? x l #t))
(arrow:keywords-match man-kwds opt-kwds x) (keywords-match man-kwds opt-kwds x)
#t)) #t))
(define (make-property chaperone?) (define (make-property chaperone?)
@ -1547,7 +1531,7 @@
(make-keyword-procedure (make-keyword-procedure
(λ (kwds kwd-args . other) (λ (kwds kwd-args . other)
(unless (null? kwds) (unless (null? kwds)
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds)) (raise-no-keywords-arg blame #:missing-party neg-party f kwds))
(unless (= 1 (length other)) (unless (= 1 (length other))
(raise-wrong-number-of-args-error (raise-wrong-number-of-args-error
#:missing-party neg-party #:missing-party neg-party