Move some contract helpers.
This commit is contained in:
Vincent St-Amour
parent
26663bb2d7
commit
a1ca38f30e
|
|
@ -12,6 +12,7 @@
|
|||
blame-add-nth-arg-context
|
||||
check-procedure check-procedure/more
|
||||
procedure-accepts-and-more?
|
||||
procedure-arity-exactly/no-kwds
|
||||
keywords-match
|
||||
(for-syntax check-tail-contract)
|
||||
matches-arity-exactly?
|
||||
|
|
@ -21,7 +22,25 @@
|
|||
tail-contract-key tail-marks-match?
|
||||
bad-number-of-results
|
||||
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 the-unsupplied-arg (make-unsupplied-arg))
|
||||
|
|
@ -243,6 +262,13 @@
|
|||
[else
|
||||
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)
|
||||
(cond
|
||||
[(zero? optionals) (procedure-arity-includes? f base #t)]
|
||||
|
|
@ -333,6 +359,26 @@
|
|||
(blame-add-context blame
|
||||
(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
|
||||
|
||||
#;
|
||||
|
|
|
|||
|
|
@ -15,12 +15,10 @@
|
|||
unsafe-impersonate-procedure))
|
||||
|
||||
(provide (for-syntax build-chaperone-constructor/real)
|
||||
procedure-arity-exactly/no-kwds
|
||||
->-proj
|
||||
check-pre-cond
|
||||
check-post-cond
|
||||
pre-post/desc-result->string
|
||||
raise-wrong-number-of-args-error
|
||||
arity-checking-wrapper)
|
||||
|
||||
(define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx))
|
||||
|
|
@ -474,7 +472,7 @@
|
|||
(let ()
|
||||
(define args-len (length 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
|
||||
args-len min-arity max-arity method?))
|
||||
|
||||
|
|
@ -500,7 +498,7 @@
|
|||
(let ()
|
||||
(unless (valid-number-of-args? 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
|
||||
args-len min-arity max-arity method?))
|
||||
(apply basic-lambda args))))
|
||||
|
|
@ -522,26 +520,6 @@
|
|||
(struct-predicate-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)
|
||||
(if (eq? arrow:unspecified-dom x)
|
||||
r
|
||||
|
|
@ -652,7 +630,7 @@
|
|||
(if okay-to-do-only-arity-check?
|
||||
(λ (val neg-party)
|
||||
(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)]))
|
||||
arrow-higher-order:lnp)]
|
||||
[else
|
||||
|
|
@ -677,7 +655,7 @@
|
|||
(if okay-to-do-only-arity-check?
|
||||
(λ (val)
|
||||
(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)
|
||||
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))
|
||||
(wrapped-extra-arg-arrow
|
||||
|
|
@ -685,10 +663,3 @@
|
|||
normal-proc)]
|
||||
[else (arrow-higher-order:vfp val)]))
|
||||
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)))))
|
||||
|
|
|
|||
|
|
@ -8,10 +8,10 @@
|
|||
"prop.rkt"
|
||||
"guts.rkt"
|
||||
"generate.rkt"
|
||||
"arrow-common.rkt"
|
||||
"arrow-higher-order.rkt"
|
||||
"list.rkt"
|
||||
racket/stxparam
|
||||
(prefix-in arrow: "arrow-common.rkt"))
|
||||
racket/stxparam)
|
||||
|
||||
(provide (rename-out [->/c ->]) ->*
|
||||
(for-syntax ->-internal ->*-internal) ; for ->m and ->*m
|
||||
|
|
@ -454,7 +454,7 @@
|
|||
(define results (call-with-values mk-call list))
|
||||
(define rng-len (length rngs))
|
||||
(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))
|
||||
(apply
|
||||
values
|
||||
|
|
@ -1126,7 +1126,7 @@
|
|||
(loop (cdr args) (cdr projs)))])))
|
||||
(define (result-checker . 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))
|
||||
(apply
|
||||
values
|
||||
|
|
@ -1160,22 +1160,6 @@
|
|||
build-chaperone-constructor
|
||||
#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)
|
||||
(cond
|
||||
[(and (equal? (length (base->-doms ctc))
|
||||
|
|
@ -1366,9 +1350,9 @@
|
|||
(kwd-info-kwd kwd-info)))
|
||||
(and (procedure? x)
|
||||
(if (base->-rest ctc)
|
||||
(arrow:procedure-accepts-and-more? x l)
|
||||
(procedure-accepts-and-more? x l)
|
||||
(procedure-arity-includes? x l #t))
|
||||
(arrow:keywords-match man-kwds opt-kwds x)
|
||||
(keywords-match man-kwds opt-kwds x)
|
||||
#t))
|
||||
|
||||
(define (make-property chaperone?)
|
||||
|
|
@ -1547,7 +1531,7 @@
|
|||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . other)
|
||||
(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))
|
||||
(raise-wrong-number-of-args-error
|
||||
#:missing-party neg-party
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user