Add support for method contracts to ->2.
Should allow removal of old -> implementation. Temporarily (almost) duplicates code, which will be fixed by removing the old ->.
This commit is contained in:
Vincent St-Amour
parent
3c074249a0
commit
585ca37c5b
|
|
@ -611,5 +611,33 @@
|
|||
(begin (set! l (cons 6 l)) #f))
|
||||
(reverse l))
|
||||
'(1 2 3 4 5 6))
|
||||
|
||||
|
||||
(contract-error-test
|
||||
'->-arity-error1
|
||||
'(contract
|
||||
(-> any/c any/c)
|
||||
(lambda (x y) #t)
|
||||
'pos 'neg)
|
||||
(lambda (e)
|
||||
(regexp-match? "a procedure that accepts 1 non-keyword argument"
|
||||
(exn-message e))))
|
||||
(contract-error-test
|
||||
'->-arity-error2
|
||||
'(contract
|
||||
(-> any/c)
|
||||
(lambda (x y) #t)
|
||||
'pos 'neg)
|
||||
(lambda (e)
|
||||
(regexp-match? "a procedure that accepts 0 non-keyword argument"
|
||||
(exn-message e))))
|
||||
(contract-error-test
|
||||
'->-arity-error3
|
||||
'(contract
|
||||
(->* (any/c) (#:x any/c) any/c)
|
||||
(lambda (x) #t)
|
||||
'pos 'neg)
|
||||
(lambda (e)
|
||||
(regexp-match? "a procedure that accepts the #:x keyword argument"
|
||||
(exn-message e))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2615,4 +2615,33 @@
|
|||
(init-field [x 0]))
|
||||
'pos 'neg)])
|
||||
(equal? (new c%) (new c%)))
|
||||
#f))
|
||||
#f)
|
||||
|
||||
(contract-error-test
|
||||
'->m-arity-error-1
|
||||
'(contract (->m string? string?)
|
||||
(lambda (y) y)
|
||||
'pos
|
||||
'neg)
|
||||
(lambda (e)
|
||||
(regexp-match? "a method that accepts 1 non-keyword argument"
|
||||
(exn-message e))))
|
||||
(contract-error-test
|
||||
'->m-arity-error-2
|
||||
'(contract (->m string?)
|
||||
(lambda () y)
|
||||
'pos
|
||||
'neg)
|
||||
(lambda (e)
|
||||
(regexp-match? "a method that accepts 0 non-keyword argument"
|
||||
(exn-message e))))
|
||||
(contract-error-test
|
||||
'->m-arity-error3
|
||||
'(contract (->*m (any/c) (#:x any/c) any/c)
|
||||
(lambda (x y) #t)
|
||||
'pos
|
||||
'neg)
|
||||
(lambda (e)
|
||||
(regexp-match? "a method that accepts the #:x keyword argument"
|
||||
(exn-message e))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -369,7 +369,7 @@
|
|||
'(let ()
|
||||
(define o
|
||||
(contract
|
||||
(object-contract (field x pos-blame?) (f (->m neg-blame?)))
|
||||
(object-contract (field x pos-blame?) (f (-> neg-blame?)))
|
||||
(new (class object% (init-field x) (define/public (f) x) (super-new)) [x 3])
|
||||
'pos 'neg))
|
||||
(get-field x o)
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
"private/basic-opters.rkt" ;; required for effect to install the opters
|
||||
"private/opt.rkt"
|
||||
"private/out.rkt"
|
||||
"private/arrow-val-first.rkt"
|
||||
(except-in "private/arrow-val-first.rkt" base->?)
|
||||
"private/orc.rkt"
|
||||
"private/list.rkt"
|
||||
"private/and.rkt")
|
||||
|
|
|
|||
|
|
@ -13,13 +13,16 @@
|
|||
->stct-doms
|
||||
->stct-rest
|
||||
->stct-min-arity
|
||||
->stct-kwd-infos)
|
||||
->stct-kwd-infos
|
||||
method?)
|
||||
(define proc/meth (if method? "a method" "a procedure"))
|
||||
(let/ec k
|
||||
(unless (procedure? val)
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a procedure" given: "~e")
|
||||
`(expected: ,proc/meth
|
||||
given: "~e")
|
||||
val))))
|
||||
(define-values (actual-mandatory-kwds actual-optional-kwds) (procedure-keywords val))
|
||||
(define arity (if (list? (procedure-arity val))
|
||||
|
|
@ -46,13 +49,17 @@
|
|||
(unless matching-arity?
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(define expected-number-of-non-keyword-args*
|
||||
((if method? sub1 values) expected-number-of-non-keyword-args))
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
"a procedure that accepts ~a non-keyword argument~a~a"
|
||||
`(expected:
|
||||
,(string-append "a "
|
||||
proc/meth
|
||||
" that accepts ~a non-keyword argument~a~a")
|
||||
given: "~e"
|
||||
"\n ~a")
|
||||
expected-number-of-non-keyword-args
|
||||
(if (= expected-number-of-non-keyword-args 1) "" "s")
|
||||
expected-number-of-non-keyword-args*
|
||||
(if (= expected-number-of-non-keyword-args* 1) "" "s")
|
||||
(if ->stct-rest
|
||||
" and arbitrarily many more"
|
||||
"")
|
||||
|
|
@ -63,25 +70,25 @@
|
|||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
"a procedure that accepts the ~a keyword argument"
|
||||
`(expected:
|
||||
,(string-append proc/meth " that accepts the ~a keyword argument")
|
||||
given: "~e"
|
||||
"\n ~a")
|
||||
kwd
|
||||
val
|
||||
(arity-as-string val)))))
|
||||
(arity-as-string val method?)))))
|
||||
|
||||
(define (should-not-have-supplied kwd)
|
||||
(k
|
||||
(λ (neg-party)
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
"a procedure that does not require the ~a keyword argument"
|
||||
`(expected:
|
||||
,(string-append proc/meth " that does not require the ~a keyword argument")
|
||||
given: "~e"
|
||||
"\n ~a")
|
||||
kwd
|
||||
val
|
||||
(arity-as-string val)))))
|
||||
(arity-as-string val method?)))))
|
||||
|
||||
(when actual-optional-kwds ;; when all kwds are okay, no checking required
|
||||
(let loop ([mandatory-kwds actual-mandatory-kwds]
|
||||
|
|
@ -115,13 +122,13 @@
|
|||
(λ (neg-party)
|
||||
(raise-blame-error
|
||||
blame #:missing-party neg-party val
|
||||
'(expected:
|
||||
"a procedure that optionally accepts the keyword ~a (this one is mandatory)"
|
||||
`(expected:
|
||||
,(string-append proc/meth " that optionally accepts the keyword ~a (this one is mandatory)")
|
||||
given: "~e"
|
||||
"\n ~a")
|
||||
val
|
||||
kwd
|
||||
(arity-as-string val)))))
|
||||
(arity-as-string val method?)))))
|
||||
(loop new-mandatory-kwds new-all-kwds (cdr kwd-infos))]
|
||||
[(keyword<? kwd (kwd-info-kwd kwd-info))
|
||||
(when mandatory?
|
||||
|
|
@ -133,14 +140,15 @@
|
|||
#f))
|
||||
|
||||
|
||||
(define (arity-as-string v)
|
||||
(define (arity-as-string v [method? #f])
|
||||
(define prefix (if (object-name v)
|
||||
(format "~a accepts: " (object-name v))
|
||||
(format "accepts: ")))
|
||||
(string-append prefix (raw-arity-as-string v)))
|
||||
(string-append prefix (raw-arity-as-string v method?)))
|
||||
|
||||
(define (raw-arity-as-string v)
|
||||
(define (raw-arity-as-string v [method? #f])
|
||||
(define ar (procedure-arity v))
|
||||
(define adjust (if method? sub1 values))
|
||||
(define (plural n) (if (= n 1) "" "s"))
|
||||
(define-values (man-kwds all-kwds) (procedure-keywords v))
|
||||
(define opt-kwds (if all-kwds (remove* man-kwds all-kwds) #f))
|
||||
|
|
@ -148,9 +156,11 @@
|
|||
(define normal-args
|
||||
(cond
|
||||
[(null? ar) "no arguments"]
|
||||
[(number? ar) (format "~a ~aargument~a" ar normal-str (plural ar))]
|
||||
[(number? ar)
|
||||
(define ar* (adjust ar))
|
||||
(format "~a ~aargument~a" ar* normal-str (plural ar*))]
|
||||
[(arity-at-least? ar) (format "~a or arbitrarily many more ~aarguments"
|
||||
(arity-at-least-value ar)
|
||||
(adjust (arity-at-least-value ar))
|
||||
normal-str)]
|
||||
[else
|
||||
(define comma
|
||||
|
|
@ -168,12 +178,12 @@
|
|||
[(arity-at-least? v)
|
||||
(list
|
||||
(format "~a, or arbitrarily many more ~aarguments"
|
||||
(arity-at-least-value v)
|
||||
(arity-at-least-value (adjust v))
|
||||
normal-str))]
|
||||
[else
|
||||
(list (format "or ~a ~aarguments" v normal-str))])]
|
||||
(list (format "or ~a ~aarguments" (adjust v) normal-str))])]
|
||||
[else
|
||||
(cons (format "~a~a " (car ar) comma)
|
||||
(cons (format "~a~a " (adjust (car ar)) comma)
|
||||
(loop (cdr ar)))])))]))
|
||||
(cond
|
||||
[(and (null? man-kwds) (null? opt-kwds))
|
||||
|
|
|
|||
|
|
@ -19,11 +19,10 @@
|
|||
->-proj
|
||||
check-pre-cond
|
||||
check-post-cond
|
||||
pre-post/desc-result->string)
|
||||
pre-post/desc-result->string
|
||||
raise-wrong-number-of-args-error)
|
||||
|
||||
(define-for-syntax (build-chaperone-constructor/real this-args
|
||||
|
||||
;; (listof (or/c #f stx))
|
||||
(define-for-syntax (build-chaperone-constructor/real ;; (listof (or/c #f stx))
|
||||
;; #f => syntactically known to be any/c
|
||||
mandatory-dom-projs
|
||||
|
||||
|
|
@ -33,7 +32,8 @@
|
|||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc)
|
||||
post post/desc
|
||||
method?)
|
||||
(define (nvars n sym) (generate-temporaries (for/list ([i (in-range n)]) sym)))
|
||||
(with-syntax ([(mandatory-dom-proj ...) (generate-temporaries mandatory-dom-projs)]
|
||||
[(optional-dom-proj ...) (generate-temporaries optional-dom-projs)]
|
||||
|
|
@ -51,7 +51,6 @@
|
|||
(define blame+neg-party (cons blame neg-party))
|
||||
#,(create-chaperone
|
||||
#'blame #'neg-party #'blame+neg-party #'blame-party-info #'f #'rng-ctcs
|
||||
this-args
|
||||
(for/list ([id (in-list (syntax->list #'(mandatory-dom-proj ...)))]
|
||||
[mandatory-dom-proj (in-list mandatory-dom-projs)])
|
||||
(and mandatory-dom-proj id))
|
||||
|
|
@ -65,7 +64,8 @@
|
|||
pre pre/desc
|
||||
(if rest (car (syntax->list #'(rest-proj ...))) #f)
|
||||
(if rngs (syntax->list #'(rng-proj ...)) #f)
|
||||
post post/desc))))
|
||||
post post/desc
|
||||
method?))))
|
||||
|
||||
|
||||
(define (check-pre-cond pre blame neg-party blame+neg-party val)
|
||||
|
|
@ -128,13 +128,13 @@
|
|||
|
||||
(define-for-syntax (create-chaperone blame neg-party blame+neg-party blame-party-info
|
||||
val rng-ctcs
|
||||
this-args
|
||||
doms opt-doms
|
||||
req-kwds opt-kwds
|
||||
pre pre/desc
|
||||
dom-rest
|
||||
rngs
|
||||
post post/desc)
|
||||
post post/desc
|
||||
method?)
|
||||
(with-syntax ([blame blame]
|
||||
[blame+neg-party blame+neg-party]
|
||||
[val val])
|
||||
|
|
@ -152,8 +152,7 @@
|
|||
[post/desc
|
||||
(list #`(check-post-cond/desc #,post/desc blame neg-party val))]
|
||||
[else null])])
|
||||
(with-syntax ([(this-param ...) this-args]
|
||||
[(dom-x ...) (generate-temporaries doms)]
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries doms)]
|
||||
[(opt-dom-ctc ...) opt-doms]
|
||||
[(opt-dom-x ...) (generate-temporaries opt-doms)]
|
||||
[(rest-ctc rest-x) (cons dom-rest (generate-temporaries '(rest)))]
|
||||
|
|
@ -194,9 +193,7 @@
|
|||
#,rng-checker))
|
||||
stx))
|
||||
|
||||
(let* ([min-method-arity (length doms)]
|
||||
[max-method-arity (+ min-method-arity (length opt-doms))]
|
||||
[min-arity (+ (length this-args) min-method-arity)]
|
||||
(let* ([min-arity (length doms)]
|
||||
[max-arity (+ min-arity (length opt-doms))]
|
||||
[req-keywords (map (λ (p) (syntax-e (car p))) req-kwds)]
|
||||
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
|
||||
|
|
@ -210,13 +207,12 @@
|
|||
[basic-params
|
||||
(cond
|
||||
[dom-rest
|
||||
#'(this-param ...
|
||||
dom-x ...
|
||||
#'(dom-x ...
|
||||
[opt-dom-x arrow:unspecified-dom] ...
|
||||
.
|
||||
rest-x)]
|
||||
[else
|
||||
#'(this-param ... dom-x ... [opt-dom-x arrow:unspecified-dom] ...)])]
|
||||
#'(dom-x ... [opt-dom-x arrow:unspecified-dom] ...)])]
|
||||
[opt+rest-uses
|
||||
(for/fold ([i (if dom-rest #'(rest-ctc rest-x neg-party) #'null)])
|
||||
([o (in-list (reverse
|
||||
|
|
@ -252,24 +248,20 @@
|
|||
|
||||
(with-syntax ([kwd-lam-params
|
||||
(if dom-rest
|
||||
#'(this-param ...
|
||||
dom-x ...
|
||||
#'(dom-x ...
|
||||
[opt-dom-x arrow:unspecified-dom] ...
|
||||
kwd-param ... . rest-x)
|
||||
#'(this-param ...
|
||||
dom-x ...
|
||||
#'(dom-x ...
|
||||
[opt-dom-x arrow:unspecified-dom] ...
|
||||
kwd-param ...))]
|
||||
[basic-return
|
||||
(let ([inner-stx-gen
|
||||
(if need-apply?
|
||||
(λ (s) #`(apply values #,@s
|
||||
this-param ...
|
||||
dom-projd-args ...
|
||||
opt+rest-uses))
|
||||
(λ (s) #`(values
|
||||
#,@s
|
||||
this-param ...
|
||||
dom-projd-args ...)))])
|
||||
(if rngs
|
||||
(arrow:check-tail-contract rng-ctcs
|
||||
|
|
@ -286,8 +278,8 @@
|
|||
(define (inner-stx-gen stuff assume-result-values? do-tail-check?)
|
||||
(define arg-checking-expressions
|
||||
(if need-apply?
|
||||
#'(this-param ... dom-projd-args ... opt+rest-uses)
|
||||
#'(this-param ... dom-projd-args ...)))
|
||||
#'(dom-projd-args ... opt+rest-uses)
|
||||
#'(dom-projd-args ...)))
|
||||
(define the-call/no-tail-mark
|
||||
(cond
|
||||
[(for/and ([dom (in-list doms)])
|
||||
|
|
@ -336,11 +328,9 @@
|
|||
(if need-apply?
|
||||
(λ (s k) #`(apply values
|
||||
#,@s #,@k
|
||||
this-param ...
|
||||
dom-projd-args ...
|
||||
opt+rest-uses))
|
||||
(λ (s k) #`(values #,@s #,@k
|
||||
this-param ...
|
||||
dom-projd-args ...)))]
|
||||
[outer-stx-gen
|
||||
(if (null? req-keywords)
|
||||
|
|
@ -393,43 +383,163 @@
|
|||
(let ()
|
||||
pre ... kwd-return)))])
|
||||
(cond
|
||||
[(and (null? req-keywords) (null? opt-keywords))
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party blame+neg-party
|
||||
basic-lambda
|
||||
basic-unsafe-lambda
|
||||
basic-unsafe-lambda/result-values-assumed
|
||||
basic-unsafe-lambda/result-values-assumed/no-tail
|
||||
#,(and rngs (length rngs))
|
||||
void
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))]
|
||||
[(pair? req-keywords)
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party blame+neg-party
|
||||
void #t #f #f #f
|
||||
kwd-lambda
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))]
|
||||
[else
|
||||
#`(arrow:arity-checking-wrapper val
|
||||
blame neg-party blame+neg-party
|
||||
basic-lambda #t #f #f #f
|
||||
kwd-lambda
|
||||
#,min-method-arity
|
||||
#,max-method-arity
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...))])))))))))
|
||||
[(and (null? req-keywords) (null? opt-keywords))
|
||||
#`(arity-checking-wrapper val
|
||||
blame neg-party blame+neg-party
|
||||
basic-lambda
|
||||
basic-unsafe-lambda
|
||||
basic-unsafe-lambda/result-values-assumed
|
||||
basic-unsafe-lambda/result-values-assumed/no-tail
|
||||
#,(and rngs (length rngs))
|
||||
void
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...)
|
||||
#,method?)]
|
||||
[(pair? req-keywords)
|
||||
#`(arity-checking-wrapper val
|
||||
blame neg-party blame+neg-party
|
||||
void #t #f #f #f
|
||||
kwd-lambda
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...)
|
||||
#,method?)]
|
||||
[else
|
||||
#`(arity-checking-wrapper val
|
||||
blame neg-party blame+neg-party
|
||||
basic-lambda #t #f #f #f
|
||||
kwd-lambda
|
||||
#,min-arity
|
||||
#,(if dom-rest #f max-arity)
|
||||
'(req-kwd ...)
|
||||
'(opt-kwd ...)
|
||||
#,method?)])))))))))
|
||||
|
||||
;; should we pass both the basic-lambda and the kwd-lambda?
|
||||
;; if basic-unsafe-lambda is #f, returns only the one value,
|
||||
;; namely the chaperone wrapper. Otherwise, returns two values,
|
||||
;; a procedure and a boolean indicating it the procedure is the
|
||||
;; basic-unsafe-lambda or not; note that basic-unsafe-lambda might
|
||||
;; also be #t, but that happens only when we know that basic-lambda
|
||||
;; can't be chosen (because there are keywords involved)
|
||||
(define (arity-checking-wrapper val blame neg-party blame+neg-party basic-lambda
|
||||
basic-unsafe-lambda
|
||||
basic-unsafe-lambda/result-values-assumed
|
||||
basic-unsafe-lambda/result-values-assumed/no-tail
|
||||
contract-result-val-count
|
||||
kwd-lambda
|
||||
min-arity max-arity
|
||||
req-kwd opt-kwd
|
||||
method?)
|
||||
;; should not build this unless we are in the 'else' case (and maybe not at all)
|
||||
(cond
|
||||
[(arrow:matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
|
||||
(if (and (null? req-kwd) (null? opt-kwd))
|
||||
(cond
|
||||
[(impersonator? val)
|
||||
(if basic-unsafe-lambda
|
||||
(values basic-lambda #f)
|
||||
basic-lambda)]
|
||||
[(and basic-unsafe-lambda
|
||||
basic-unsafe-lambda/result-values-assumed
|
||||
(equal? contract-result-val-count
|
||||
(procedure-result-arity val)))
|
||||
(if (simple-enough? val)
|
||||
(values basic-unsafe-lambda/result-values-assumed/no-tail #t)
|
||||
(values basic-unsafe-lambda/result-values-assumed #t))]
|
||||
[basic-unsafe-lambda
|
||||
(values basic-unsafe-lambda #t)]
|
||||
[else basic-lambda])
|
||||
(if basic-unsafe-lambda
|
||||
(values kwd-lambda #f)
|
||||
kwd-lambda))]
|
||||
[else
|
||||
(define-values (vr va) (procedure-keywords val))
|
||||
(define all-kwds (append req-kwd opt-kwd))
|
||||
(define (valid-number-of-args? args)
|
||||
(if max-arity
|
||||
(<= min-arity (length args) max-arity)
|
||||
(<= min-arity (length args))))
|
||||
(define kwd-checker
|
||||
(if (and (null? req-kwd) (null? opt-kwd))
|
||||
(λ (kwds kwd-args . args)
|
||||
(arrow:raise-no-keywords-arg blame #:missing-party neg-party val kwds))
|
||||
(λ (kwds kwd-args . args)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(let ()
|
||||
(define args-len (length args))
|
||||
(unless (valid-number-of-args? args)
|
||||
(raise-wrong-number-of-args-error
|
||||
blame #:missing-party neg-party val
|
||||
args-len min-arity max-arity method?))
|
||||
|
||||
;; these two for loops are doing O(n^2) work that could be linear
|
||||
;; (since the keyword lists are sorted)
|
||||
(for ([req-kwd (in-list req-kwd)])
|
||||
(unless (memq req-kwd kwds)
|
||||
(raise-blame-error (blame-swap blame) #:missing-party neg-party
|
||||
val
|
||||
'(expected "keyword argument ~a")
|
||||
req-kwd)))
|
||||
(for ([k (in-list kwds)])
|
||||
(unless (memq k all-kwds)
|
||||
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
|
||||
'(received: "unexpected keyword argument ~a")
|
||||
k)))
|
||||
(keyword-apply kwd-lambda kwds kwd-args args))))))
|
||||
(define basic-checker-name
|
||||
(if (null? req-kwd)
|
||||
(λ args
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(let ()
|
||||
(unless (valid-number-of-args? args)
|
||||
(define args-len (length args))
|
||||
(raise-wrong-number-of-args-error
|
||||
blame #:missing-party neg-party val
|
||||
args-len min-arity max-arity method?))
|
||||
(apply basic-lambda args))))
|
||||
(λ args
|
||||
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
|
||||
"expected required keyword ~a"
|
||||
(car req-kwd)))))
|
||||
(define proc
|
||||
(if (or (not va) (pair? vr) (pair? va))
|
||||
(make-keyword-procedure kwd-checker basic-checker-name)
|
||||
basic-checker-name))
|
||||
(if basic-unsafe-lambda
|
||||
(values proc #f)
|
||||
proc)]))
|
||||
|
||||
(define (simple-enough? f)
|
||||
(or (struct-accessor-procedure? f)
|
||||
(struct-constructor-procedure? f)
|
||||
(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)
|
||||
|
|
@ -439,7 +549,7 @@
|
|||
(define (->-proj chaperone? ctc
|
||||
;; fields of the 'ctc' struct
|
||||
min-arity doms kwd-infos rest pre? rngs post?
|
||||
plus-one-arity-function chaperone-constructor
|
||||
plus-one-arity-function chaperone-constructor method?
|
||||
late-neg?)
|
||||
(define optionals-length (- (length doms) min-arity))
|
||||
(define mtd? #f) ;; not yet supported for the new contracts
|
||||
|
|
@ -460,7 +570,7 @@
|
|||
[n (in-naturals 1)])
|
||||
((get/build-late-neg-projection dom)
|
||||
(blame-add-context orig-blame
|
||||
(format "the ~a argument of" (n->th n))
|
||||
(format "the ~a argument of" (n->th (if method? (sub1 n) n)))
|
||||
#:swap? #t))))
|
||||
(define rest-blame
|
||||
(if (ellipsis-rest-arg-ctc? rest)
|
||||
|
|
@ -532,7 +642,7 @@
|
|||
[late-neg?
|
||||
(define (arrow-higher-order:lnp val neg-party)
|
||||
(cond
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos method?)
|
||||
=>
|
||||
(λ (f)
|
||||
(f neg-party))]
|
||||
|
|
@ -549,7 +659,7 @@
|
|||
(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))
|
||||
(cond
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
|
||||
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos method?)
|
||||
=>
|
||||
(λ (neg-party-acceptor)
|
||||
;; probably don't need to include the wrapped-extra-arrow wrapper
|
||||
|
|
|
|||
|
|
@ -14,34 +14,20 @@
|
|||
(prefix-in arrow: "arrow.rkt"))
|
||||
|
||||
(provide ->2 ->*2
|
||||
->2-internal ->*2-internal ; for ->m and ->*m
|
||||
base->? base->-name ; for object-contract
|
||||
dynamic->*
|
||||
(for-syntax ->2-handled?
|
||||
->2-arity-check-only->?
|
||||
->*2-handled?
|
||||
(for-syntax ->2-arity-check-only->?
|
||||
->2*-arity-check-only->?
|
||||
->-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 boolean?)
|
||||
[(_ args ...)
|
||||
(syntax-parameter-value #'arrow:making-a-method)
|
||||
#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 ...)
|
||||
(syntax-parameter-value #'arrow:making-a-method)
|
||||
#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))))]
|
||||
|
|
@ -106,14 +92,19 @@
|
|||
(generate-popular-key-ids popular-key-ids)
|
||||
|
||||
(define-for-syntax (build-plus-one-arity-function+chaperone-constructor
|
||||
regular-args
|
||||
pre-regular-args
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc)
|
||||
post post/desc
|
||||
method?)
|
||||
(define regular-args
|
||||
(if method?
|
||||
(cons #'any/c pre-regular-args) ; add `this` argument
|
||||
pre-regular-args))
|
||||
(define regular-args/no-any/c
|
||||
(for/list ([stx (in-list regular-args)])
|
||||
(syntax-case stx (any/c)
|
||||
|
|
@ -145,9 +136,9 @@
|
|||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc)
|
||||
post post/desc
|
||||
method?)
|
||||
(build-chaperone-constructor/real
|
||||
'() ;; this-args
|
||||
regular-args/no-any/c
|
||||
optional-args
|
||||
mandatory-kwds
|
||||
|
|
@ -155,7 +146,8 @@
|
|||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc))]))
|
||||
post post/desc
|
||||
method?))]))
|
||||
|
||||
(define-syntax (build-populars stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -192,17 +184,16 @@
|
|||
#f #f
|
||||
rest
|
||||
rng-vars
|
||||
#f #f))
|
||||
#f #f #f))
|
||||
(define #,(syntax-local-introduce chaperone-id)
|
||||
#,(let ([ans (build-chaperone-constructor/real
|
||||
'() ;; this arg
|
||||
mans/no-any/c opts
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
#f #f
|
||||
rest
|
||||
rng-vars
|
||||
#f #f)])
|
||||
#f #f #f)])
|
||||
#;
|
||||
(when (equal? key (list '(#t) 0 '() '() #f 1))
|
||||
((dynamic-require 'racket/pretty 'pretty-write) (syntax->datum ans))
|
||||
|
|
@ -222,7 +213,8 @@
|
|||
pre pre/desc
|
||||
rest
|
||||
rngs
|
||||
post post/desc)
|
||||
post post/desc
|
||||
method?)
|
||||
(with-syntax ([(regb ...) (generate-temporaries regular-args)]
|
||||
[(optb ...) (generate-temporaries optional-args)]
|
||||
[(kb ...) (generate-temporaries mandatory-kwds)]
|
||||
|
|
@ -369,10 +361,11 @@
|
|||
#,(if pre pre #'#f)
|
||||
'(#,@mandatory-kwds) (list kb ...)
|
||||
'(#,@optional-kwds) (list okb ...)
|
||||
#,(length regular-args) (list regb ... optb ...)
|
||||
#,(length regular-args) (list regb ... optb ...)
|
||||
#,(if rest #'restb #'#f)
|
||||
#,(if post post #'#f)
|
||||
#,(if rngs #'(list rb ...) #'#f))]))
|
||||
#,(if rngs #'(list rb ...) #'#f)
|
||||
#,method?)]))
|
||||
(define body-proc (make-body-proc #t))
|
||||
(define body-proc/no-range-checking (make-body-proc #f))
|
||||
(define number-of-rngs (and rngs (with-syntax ([rngs rngs]) (length (syntax->list #'rngs)))))
|
||||
|
|
@ -396,10 +389,11 @@
|
|||
original-mandatory-kwds kbs
|
||||
original-optional-kwds okbs
|
||||
minimum-arg-count rbs rest-ctc
|
||||
post rngs)
|
||||
post rngs
|
||||
method?)
|
||||
(make-keyword-procedure
|
||||
(λ (actual-kwds actual-kwd-args neg-party . regular-args)
|
||||
(check-arg-count minimum-arg-count (length rbs) regular-args f blame neg-party rest-ctc)
|
||||
(check-arg-count minimum-arg-count (length rbs) regular-args f blame neg-party rest-ctc method?)
|
||||
(check-keywords original-mandatory-kwds original-optional-kwds actual-kwds f blame neg-party)
|
||||
(define (mk-call)
|
||||
(keyword-apply
|
||||
|
|
@ -483,8 +477,9 @@
|
|||
rngs))
|
||||
(hash-ref popular-chaperone-key-table key #f))
|
||||
|
||||
(define (check-arg-count minimum-arg-count len-rbs regular-args val blame neg-party rest-ctc)
|
||||
(define (check-arg-count minimum-arg-count len-rbs regular-args val blame neg-party rest-ctc method?)
|
||||
(define actual-count (length regular-args))
|
||||
(define adjust (if method? sub1 values))
|
||||
(cond
|
||||
[(< actual-count minimum-arg-count)
|
||||
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
|
||||
|
|
@ -492,14 +487,14 @@
|
|||
(if (= len-rbs minimum-arg-count)
|
||||
""
|
||||
"at least ")
|
||||
minimum-arg-count)]
|
||||
(adjust minimum-arg-count))]
|
||||
[(and (not rest-ctc) (< len-rbs actual-count))
|
||||
(raise-blame-error (blame-swap blame) #:missing-party neg-party val
|
||||
'(expected: "~a~a arguments")
|
||||
(if (= len-rbs minimum-arg-count)
|
||||
""
|
||||
"at most ")
|
||||
len-rbs)]))
|
||||
(adjust len-rbs))]))
|
||||
|
||||
(define (check-keywords mandatory-kwds optional-kwds kwds val blame neg-party)
|
||||
(let loop ([mandatory-kwds mandatory-kwds]
|
||||
|
|
@ -646,11 +641,18 @@
|
|||
|
||||
(define-syntax (->2 stx)
|
||||
(syntax-case stx ()
|
||||
[(_ args ...)
|
||||
(not (->2-handled? stx))
|
||||
#'(arrow:-> args ...)]
|
||||
[(_ args ... rng)
|
||||
[(_ . args)
|
||||
(let ()
|
||||
#`(syntax-parameterize
|
||||
((arrow:making-a-method #f))
|
||||
#,(quasisyntax/loc stx
|
||||
(->2-internal -> . args))))]))
|
||||
|
||||
(define-syntax (->2-internal stx*)
|
||||
(syntax-case stx* ()
|
||||
[(_ orig-> args ... rng)
|
||||
(let ()
|
||||
(define stx (syntax/loc stx* (orig-> args ... rng)))
|
||||
(define this-> (gensym 'this->))
|
||||
(define-values (regular-args kwds kwd-args let-bindings ellipsis-info)
|
||||
(parse-arrow-args stx (syntax->list #'(args ...)) this->))
|
||||
|
|
@ -662,24 +664,29 @@
|
|||
[any #f]
|
||||
[(values rng ...) (add-pos-obligations (syntax->list #'(rng ...)))]
|
||||
[rng (add-pos-obligations (list #'rng))]))
|
||||
(define method? (syntax-parameter-value #'arrow:making-a-method))
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f))
|
||||
regular-args '() kwds '() #f #f (and ellipsis-info #t) rngs #f #f
|
||||
method?))
|
||||
(syntax-property
|
||||
#`(let #,let-bindings
|
||||
#,(quasisyntax/loc stx
|
||||
(build-simple-->
|
||||
(list #,@regular-args)
|
||||
'(#,@kwds)
|
||||
(list #,@kwd-args)
|
||||
#,(if rngs
|
||||
#`(list #,@rngs)
|
||||
#'#f)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,(if ellipsis-info
|
||||
#`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
|
||||
#'#f))))
|
||||
#`(syntax-parameterize
|
||||
([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one
|
||||
(let #,let-bindings
|
||||
#,(quasisyntax/loc stx
|
||||
(build-simple-->
|
||||
(list #,@regular-args)
|
||||
'(#,@kwds)
|
||||
(list #,@kwd-args)
|
||||
#,(if rngs
|
||||
#`(list #,@rngs)
|
||||
#'#f)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,(if ellipsis-info
|
||||
#`(ellipsis-rest-arg #,(length regular-args) #,@ellipsis-info)
|
||||
#'#f)
|
||||
#,method?))))
|
||||
'racket/contract:contract
|
||||
(vector this->
|
||||
;; the -> in the original input to this guy
|
||||
|
|
@ -768,73 +775,81 @@
|
|||
(syntax->datum #'(optional-dom-kwd ...)))))
|
||||
|
||||
(define-syntax (->*2 stx)
|
||||
(cond
|
||||
[(->*2-handled? stx)
|
||||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(parse->*2 stx this->*))
|
||||
(with-syntax ([(mandatory-dom ...) man-dom]
|
||||
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
[(mandatory-let-bindings ...) man-lets]
|
||||
[(optional-dom ...) opt-dom]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]
|
||||
[(optional-let-bindings ...) opt-lets]
|
||||
[(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
|
||||
(with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
|
||||
(optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
|
||||
[(pre-let-binding ...) (if (or pre pre/desc)
|
||||
(list #`[pre-x (λ () #,(or pre pre/desc))])
|
||||
(list))]
|
||||
[(post-let-binding ...) (if (or post post/desc)
|
||||
(list #`[post-x (λ () #,(or post post/desc))])
|
||||
(list))])
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
(syntax->list #'(mandatory-dom ...))
|
||||
(syntax->list #'(optional-dom ...))
|
||||
(syntax->list #'(mandatory-dom-kwd ...))
|
||||
(syntax->list #'(optional-dom-kwd ...))
|
||||
(and pre #'pre-x)
|
||||
(and pre/desc #'pre-x)
|
||||
rest-ctc
|
||||
rng-ctcs
|
||||
(and post #'post-x)
|
||||
(and post/desc #'post-x)))
|
||||
(syntax-property
|
||||
#`(let (mandatory-let-bindings ...
|
||||
optional-let-bindings ...
|
||||
pre-let-binding ...
|
||||
post-let-binding ...)
|
||||
(build--> '->*
|
||||
(list mandatory-dom ...)
|
||||
(list optional-dom ...)
|
||||
'(mandatory-dom-kwd ...)
|
||||
(list mandatory-dom-kwd-ctc ...)
|
||||
'(optional-dom-kwd ...)
|
||||
(list optional-dom-kwd-ctc ...)
|
||||
#,rest-ctc
|
||||
#,(and pre #t)
|
||||
#,(if rng-ctcs
|
||||
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
|
||||
(syntax-property rng-ctc
|
||||
'racket/contract:positive-position
|
||||
this->*)))
|
||||
#'#f)
|
||||
#,(and post #t)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor))
|
||||
|
||||
'racket/contract:contract
|
||||
(vector this->*
|
||||
;; the -> in the original input to this guy
|
||||
(list (car (syntax-e stx)))
|
||||
'()))))]
|
||||
[else
|
||||
(syntax-case stx ()
|
||||
[(_ args ...)
|
||||
#'(arrow:->* args ...)])]))
|
||||
(syntax-case stx ()
|
||||
[(_ . args)
|
||||
#`(syntax-parameterize
|
||||
((arrow:making-a-method #f))
|
||||
#,(quasisyntax/loc stx
|
||||
(->*2-internal ->* . args)))]))
|
||||
|
||||
(define-syntax (->*2-internal stx*)
|
||||
(define stx (syntax-case stx* () [(_ orig->* . args) (syntax/loc stx* (orig->* . args))]))
|
||||
(define this->* (gensym 'this->*))
|
||||
(define-values (man-dom man-dom-kwds man-lets
|
||||
opt-dom opt-dom-kwds opt-lets
|
||||
rest-ctc pre pre/desc rng-ctcs post post/desc)
|
||||
(parse->*2 stx this->*))
|
||||
(with-syntax ([(mandatory-dom ...) man-dom]
|
||||
[((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds]
|
||||
[(mandatory-let-bindings ...) man-lets]
|
||||
[(optional-dom ...) opt-dom]
|
||||
[((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]
|
||||
[(optional-let-bindings ...) opt-lets]
|
||||
[(pre-x post-x) (generate-temporaries '(pre-cond post-cond))])
|
||||
(with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ...
|
||||
(optional-dom-kwd optional-dom-kwd-ctc #t) ...)]
|
||||
[(pre-let-binding ...) (if (or pre pre/desc)
|
||||
(list #`[pre-x (λ () #,(or pre pre/desc))])
|
||||
(list))]
|
||||
[(post-let-binding ...) (if (or post post/desc)
|
||||
(list #`[post-x (λ () #,(or post post/desc))])
|
||||
(list))])
|
||||
(define method? (syntax-parameter-value #'arrow:making-a-method))
|
||||
(define-values (plus-one-arity-function chaperone-constructor)
|
||||
(build-plus-one-arity-function+chaperone-constructor
|
||||
(syntax->list #'(mandatory-dom ...))
|
||||
(syntax->list #'(optional-dom ...))
|
||||
(syntax->list #'(mandatory-dom-kwd ...))
|
||||
(syntax->list #'(optional-dom-kwd ...))
|
||||
(and pre #'pre-x)
|
||||
(and pre/desc #'pre-x)
|
||||
rest-ctc
|
||||
rng-ctcs
|
||||
(and post #'post-x)
|
||||
(and post/desc #'post-x)
|
||||
method?))
|
||||
(syntax-property
|
||||
#`(let (mandatory-let-bindings ...
|
||||
optional-let-bindings ...
|
||||
pre-let-binding ...
|
||||
post-let-binding ...)
|
||||
(syntax-parameterize
|
||||
([arrow:making-a-method #f]) ; subcontracts are not method contracts, even if we ourselves are one
|
||||
(build--> '->*
|
||||
(list mandatory-dom ...)
|
||||
(list optional-dom ...)
|
||||
'(mandatory-dom-kwd ...)
|
||||
(list mandatory-dom-kwd-ctc ...)
|
||||
'(optional-dom-kwd ...)
|
||||
(list optional-dom-kwd-ctc ...)
|
||||
#,rest-ctc
|
||||
#,(and pre #t)
|
||||
#,(if rng-ctcs
|
||||
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
|
||||
(syntax-property rng-ctc
|
||||
'racket/contract:positive-position
|
||||
this->*)))
|
||||
#'#f)
|
||||
#,(and post #t)
|
||||
#,plus-one-arity-function
|
||||
#,chaperone-constructor
|
||||
#,method?)))
|
||||
|
||||
'racket/contract:contract
|
||||
(vector this->*
|
||||
;; the -> in the original input to this guy
|
||||
(list (car (syntax-e stx)))
|
||||
'())))))
|
||||
|
||||
(define (wrong-number-of-results-blame blame neg-party val reses expected-values)
|
||||
(define length-reses (length reses))
|
||||
|
|
@ -851,7 +866,8 @@
|
|||
raw-rngs
|
||||
plus-one-arity-function
|
||||
chaperone-constructor
|
||||
raw-rest-ctc)
|
||||
raw-rest-ctc
|
||||
method?)
|
||||
(build--> '->
|
||||
raw-regular-doms '()
|
||||
mandatory-kwds mandatory-raw-kwd-doms
|
||||
|
|
@ -859,16 +875,22 @@
|
|||
raw-rest-ctc
|
||||
#f raw-rngs #f
|
||||
plus-one-arity-function
|
||||
chaperone-constructor))
|
||||
chaperone-constructor
|
||||
method?))
|
||||
|
||||
(define (build--> who
|
||||
raw-regular-doms raw-optional-doms
|
||||
pre-raw-regular-doms raw-optional-doms
|
||||
mandatory-kwds mandatory-raw-kwd-doms
|
||||
optional-kwds optional-raw-kwd-doms
|
||||
raw-rest-ctc
|
||||
pre-cond raw-rngs post-cond
|
||||
plus-one-arity-function
|
||||
chaperone-constructor)
|
||||
chaperone-constructor
|
||||
method?)
|
||||
(define raw-regular-doms
|
||||
(if method?
|
||||
(cons any/c pre-raw-regular-doms) ; `this` argument
|
||||
pre-raw-regular-doms))
|
||||
(define regular-doms
|
||||
(for/list ([dom (in-list (append raw-regular-doms raw-optional-doms))])
|
||||
(coerce-contract who dom)))
|
||||
|
|
@ -922,13 +944,15 @@
|
|||
regular-doms kwd-infos rest-ctc pre-cond
|
||||
rngs post-cond
|
||||
plus-one-arity-function
|
||||
chaperone-constructor)]
|
||||
chaperone-constructor
|
||||
method?)]
|
||||
[else
|
||||
(make-impersonator-> (length raw-regular-doms)
|
||||
regular-doms kwd-infos rest-ctc pre-cond
|
||||
rngs post-cond
|
||||
plus-one-arity-function
|
||||
chaperone-constructor)]))
|
||||
chaperone-constructor
|
||||
method?)]))
|
||||
|
||||
(define (dynamic->* #:mandatory-domain-contracts [mandatory-domain-contracts '()]
|
||||
#:optional-domain-contracts [optional-domain-contracts '()]
|
||||
|
|
@ -1040,7 +1064,7 @@
|
|||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . args)
|
||||
|
||||
(check-arg-count min-arity max-arity args f blame neg-party rest-contract)
|
||||
(check-arg-count min-arity max-arity args f blame neg-party rest-contract #f)
|
||||
(check-keywords mandatory-keywords optional-keywords kwds f blame neg-party)
|
||||
|
||||
(define kwd-results
|
||||
|
|
@ -1090,7 +1114,8 @@
|
|||
rest-contract
|
||||
pre-cond range-contracts post-cond
|
||||
plus-one-arity-function
|
||||
build-chaperone-constructor))
|
||||
build-chaperone-constructor
|
||||
#f)) ; not a method contract
|
||||
|
||||
;; min-arity : nat
|
||||
;; doms : (listof contract?)[len >= min-arity]
|
||||
|
|
@ -1102,8 +1127,10 @@
|
|||
;; post? : boolean?
|
||||
;; 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)
|
||||
plus-one-arity-function chaperone-constructor
|
||||
method?)
|
||||
#:property prop:custom-write custom-write-property-proc)
|
||||
|
||||
(define (->-generate ctc)
|
||||
|
|
@ -1198,10 +1225,20 @@
|
|||
[else
|
||||
(λ (fuel) (values void '()))]))
|
||||
|
||||
(define (base->-name ctc)
|
||||
;; print-as-method-if-method?: Usually, whether an `->` is printed as `->m` is
|
||||
;; determined by whether the contract has an implicit `any/c` for the `this`
|
||||
;; argument.
|
||||
;; Unfortunately, this is not always the case. `object-contract` creates
|
||||
;; contracts that *look* like function contracts (i.e. print as `->`), but act
|
||||
;; like method contracts. Therefore, `object-contract` printing needs to
|
||||
;; override our behavior.
|
||||
;; That was probably not good design, but we're stuck with it.
|
||||
(define ((base->-name print-as-method-if-method?) ctc)
|
||||
(cond
|
||||
[(predicate/c? ctc) 'predicate/c]
|
||||
[else
|
||||
(define method? (base->-method? ctc))
|
||||
(define arr (if (and method? print-as-method-if-method?) '->m '->))
|
||||
(define rngs (base->-rngs ctc))
|
||||
(define rng-sexp
|
||||
(cond
|
||||
|
|
@ -1224,23 +1261,25 @@
|
|||
(for/list ([kwd-info (in-list (base->-kwd-infos ctc))])
|
||||
(list (kwd-info-kwd kwd-info)
|
||||
(contract-name (kwd-info-ctc kwd-info))))))
|
||||
(define doms ((if method? cdr values) (map contract-name (base->-doms ctc))))
|
||||
(cond
|
||||
[(ellipsis-rest-arg-ctc? (base->-rest ctc))
|
||||
`(-> ,@(map contract-name (base->-doms ctc))
|
||||
,@kwd-args
|
||||
,(contract-name (*list-ctc-prefix (base->-rest ctc)))
|
||||
...
|
||||
,@(for/list ([ctc (in-list (*list-ctc-suffix (base->-rest ctc)))])
|
||||
(contract-name ctc))
|
||||
,rng-sexp)]
|
||||
`(,arr ,@doms
|
||||
,@kwd-args
|
||||
,(contract-name (*list-ctc-prefix (base->-rest ctc)))
|
||||
...
|
||||
,@(for/list ([ctc (in-list (*list-ctc-suffix (base->-rest ctc)))])
|
||||
(contract-name ctc))
|
||||
,rng-sexp)]
|
||||
[else
|
||||
`(-> ,@(map contract-name (base->-doms ctc))
|
||||
,@kwd-args
|
||||
,rng-sexp)])]
|
||||
`(,arr ,@doms
|
||||
,@kwd-args
|
||||
,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)))
|
||||
`(,@(map contract-name
|
||||
((if method? cdr values) (take (base->-doms ctc) (base->-min-arity ctc))))
|
||||
,@(apply
|
||||
append
|
||||
(for/list ([kwd-info (base->-kwd-infos ctc)]
|
||||
|
|
@ -1256,21 +1295,21 @@
|
|||
#: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 arr* (if (and method? print-as-method-if-method?) '->*m '->*))
|
||||
`(,arr* ,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))
|
||||
|
|
@ -1303,6 +1342,7 @@
|
|||
(base->-post? ->stct)
|
||||
(base->-plus-one-arity-function ->stct)
|
||||
(base->-chaperone-constructor ->stct)
|
||||
(base->-method? ->stct)
|
||||
#f)))
|
||||
(define late-neg-proj
|
||||
(λ (->stct)
|
||||
|
|
@ -1316,9 +1356,10 @@
|
|||
(base->-post? ->stct)
|
||||
(base->-plus-one-arity-function ->stct)
|
||||
(base->-chaperone-constructor ->stct)
|
||||
(base->-method? ->stct)
|
||||
#t)))
|
||||
(build-X-property
|
||||
#:name base->-name
|
||||
#:name (base->-name #|print-as-method-if-method|# #t)
|
||||
#:first-order ->-first-order
|
||||
#:projection
|
||||
(λ (this)
|
||||
|
|
@ -1399,7 +1440,8 @@
|
|||
'(expected: "void?" given: "~e")
|
||||
rng))))
|
||||
1))
|
||||
(get-chaperone-constructor))))
|
||||
(get-chaperone-constructor)
|
||||
#f))) ; not a method contract
|
||||
|
||||
(define (mk-any/c->boolean-contract constructor)
|
||||
(define (check-result blame neg-party rng)
|
||||
|
|
@ -1462,11 +1504,13 @@
|
|||
(unless (null? kwds)
|
||||
(arrow:raise-no-keywords-arg blame #:missing-party neg-party f kwds))
|
||||
(unless (= 1 (length other))
|
||||
(arrow:raise-wrong-number-of-args-error
|
||||
(raise-wrong-number-of-args-error
|
||||
#:missing-party neg-party
|
||||
blame f (length other) 1 1 1))
|
||||
blame f (length other) 1 1 1
|
||||
#f)) ; not a method contract
|
||||
(values (rng-checker f blame neg-party) (car other))))])
|
||||
#f))))
|
||||
#f))
|
||||
#f)) ; not a method contract
|
||||
|
||||
(define -predicate/c (mk-any/c->boolean-contract predicate/c))
|
||||
(define any/c->boolean-contract (mk-any/c->boolean-contract make-->))
|
||||
|
|
|
|||
|
|
@ -42,7 +42,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
|
||||
base-->d? ->d-name) ; for object-contract
|
||||
|
||||
(define-syntax-parameter making-a-method #f)
|
||||
(define-syntax-parameter method-contract? #f)
|
||||
|
|
@ -1602,8 +1603,9 @@
|
|||
optional-kwds
|
||||
name-wrapper)))
|
||||
|
||||
(define (->d-name ctc)
|
||||
(let* ([name (if (base-->d-mctc? ctc) '->dm '->d)]
|
||||
;; Re `print-as-method-if-method?`: See comment before `base->-name` in arrow-val-first.rkt
|
||||
(define ((->d-name print-as-method-if-method?) ctc)
|
||||
(let* ([name (if (and (base-->d-mctc? ctc) print-as-method-if-method?) '->dm '->d)]
|
||||
[counting-id 'x]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
|
|
@ -1694,7 +1696,7 @@
|
|||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:late-neg-projection (late-neg-->d-proj impersonate-procedure)
|
||||
#:name ->d-name
|
||||
#:name (->d-name #|print-as-method-if-method?|# #t)
|
||||
#:first-order ->d-first-order
|
||||
#:stronger ->d-stronger?))
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
"misc.rkt"
|
||||
"arrow.rkt"
|
||||
(except-in "arrow.rkt" base->?)
|
||||
"arrow-val-first.rkt")
|
||||
|
||||
(provide case->)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
#lang racket/base
|
||||
(require "arrow.rkt"
|
||||
(require "arrow-val-first.rkt"
|
||||
"case-arrow.rkt"
|
||||
(only-in "arrow.rkt" ->d base-->d? ->d-name making-a-method)
|
||||
"arr-i.rkt"
|
||||
"guts.rkt"
|
||||
"prop.rkt"
|
||||
|
|
@ -39,6 +41,15 @@
|
|||
[_
|
||||
(raise-syntax-error #f "malformed object-contract clause" stx (car args))])])))
|
||||
|
||||
;; similar to `build-compound-type-name`, but handles method contract names
|
||||
(define (object-contract-sub-name . fs)
|
||||
(for/list ([sub (in-list fs)])
|
||||
(cond [(base->? sub) ((base->-name #|print-as-method-if-method?|# #f) sub)] ; covers -> and ->*
|
||||
[(base-->d? sub) ((->d-name #|print-as-method-if-method?|# #f) sub)]
|
||||
;; `->i` and `case->` will naturally print correctly, due to the way they handle methods
|
||||
[(contract-struct? sub) (contract-struct-name sub)]
|
||||
[else sub])))
|
||||
|
||||
(define-struct object-contract (methods method-ctcs fields field-ctcs)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:omit-define-syntaxes
|
||||
|
|
@ -55,7 +66,7 @@
|
|||
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
|
||||
(object-contract-fields ctc)
|
||||
(object-contract-field-ctcs ctc))
|
||||
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
|
||||
,@(map (λ (mtd ctc) (object-contract-sub-name mtd ctc))
|
||||
(object-contract-methods ctc)
|
||||
(object-contract-method-ctcs ctc))))
|
||||
|
||||
|
|
@ -78,9 +89,18 @@
|
|||
#'(build-object-contract '(method-id ...)
|
||||
(syntax-parameterize
|
||||
((making-a-method #t))
|
||||
(list (let ([method-name method-ctc]) method-name) ...))
|
||||
(list (let ([method-name (fun->meth method-ctc)]) method-name) ...))
|
||||
'(field-id ...)
|
||||
(list field-ctc ...))))]))
|
||||
(define-syntax (fun->meth stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ctc)
|
||||
(syntax-case #'ctc (->2 ->*2 ->d ->i case->)
|
||||
[(->2 . args) #'(->m . args)]
|
||||
[(->*2 . args) #'(->*m . args)]
|
||||
[(->d . args) #'(->dm . args)]
|
||||
[(->i . args) #'ctc] ; ->i doesn't reset the `making-a-method` syntax parameter
|
||||
[(case-> case ...) #'ctc])])) ; neither does case->
|
||||
|
||||
(define (build-object-contract methods method-ctcs fields field-ctcs)
|
||||
(make-object-contract methods
|
||||
|
|
|
|||
|
|
@ -2,9 +2,8 @@
|
|||
(require "misc.rkt"
|
||||
"opt.rkt"
|
||||
"guts.rkt"
|
||||
"arrow.rkt"
|
||||
"blame.rkt"
|
||||
"arrow.rkt"
|
||||
(except-in "arrow.rkt" base->?)
|
||||
"arrow-val-first.rkt"
|
||||
"arrow-higher-order.rkt"
|
||||
"orc.rkt"
|
||||
|
|
|
|||
|
|
@ -281,12 +281,10 @@
|
|||
(define-values (arrow? the-valid-app-shapes)
|
||||
(syntax-case ctrct (->2 ->*2 ->i)
|
||||
[(->2 . _)
|
||||
(and (->2-handled? ctrct)
|
||||
(not (->2-arity-check-only->? ctrct)))
|
||||
(not (->2-arity-check-only->? ctrct))
|
||||
(values #t (->-valid-app-shapes ctrct))]
|
||||
[(->*2 . _)
|
||||
(values (and (->*2-handled? ctrct)
|
||||
(not (->2*-arity-check-only->? ctrct)))
|
||||
(values (not (->2*-arity-check-only->? ctrct))
|
||||
(->*-valid-app-shapes ctrct))]
|
||||
[(->i . _) (values #t (->i-valid-app-shapes ctrct))]
|
||||
[_ (values #f #f)]))
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@
|
|||
"class-internal.rkt"
|
||||
"../contract/base.rkt"
|
||||
"../contract/combinator.rkt"
|
||||
(only-in "../contract/private/arrow.rkt" making-a-method method-contract?))
|
||||
(only-in "../contract/private/arrow.rkt" making-a-method method-contract?)
|
||||
(only-in "../contract/private/arrow-val-first.rkt" ->2-internal ->*2-internal))
|
||||
|
||||
(provide make-class/c class/c-late-neg-proj
|
||||
blame-add-method-context blame-add-field-context blame-add-init-context
|
||||
|
|
@ -25,10 +26,10 @@
|
|||
;; Shorthand contracts that treat the implicit object argument as if it were
|
||||
;; contracted with any/c.
|
||||
(define-syntax-rule (->m . stx)
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (-> . stx)))
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->2-internal ->m . stx)))
|
||||
|
||||
(define-syntax-rule (->*m . stx)
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->* . stx)))
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (->*2-internal ->*m . stx)))
|
||||
|
||||
(define-syntax-rule (case->m . stx)
|
||||
(syntax-parameterize ([making-a-method #t] [method-contract? #t]) (case-> . stx)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user