From a1ca38f30e15c9839b4e27f657e3da579bb705a2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 20 May 2016 13:47:38 -0500 Subject: [PATCH] Move some contract helpers. --- .../racket/contract/private/arrow-common.rkt | 48 ++++++++++++++++++- .../contract/private/arrow-higher-order.rkt | 37 ++------------ .../contract/private/arrow-val-first.rkt | 30 +++--------- 3 files changed, 58 insertions(+), 57 deletions(-) diff --git a/racket/collects/racket/contract/private/arrow-common.rkt b/racket/collects/racket/contract/private/arrow-common.rkt index ba4975d77d..aaf666a81d 100644 --- a/racket/collects/racket/contract/private/arrow-common.rkt +++ b/racket/collects/racket/contract/private/arrow-common.rkt @@ -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 #; diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 8c194fd794..780b0e8caf 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -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))))) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 56924bd3cc..cc4555bd83 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -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