Refactor out new has-contract?/value-contract functionality so that it's
the responsibility of the (higher-order) contract to add the contract (plus possibly more in the future) to the wrapped value. svn: r18469
This commit is contained in:
Stevie Strickland
parent
0d8fbe6d06
commit
bf60da75e1
|
|
@ -22,6 +22,10 @@
|
|||
opt->*
|
||||
unconstrained-domain->)
|
||||
|
||||
(define-struct contracted-function (proc ctc)
|
||||
#:property prop:procedure 0
|
||||
#:property prop:contracted 1)
|
||||
|
||||
(define-syntax (unconstrained-domain-> stx)
|
||||
(syntax-case stx ()
|
||||
[(_ rngs ...)
|
||||
|
|
@ -31,19 +35,23 @@
|
|||
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
||||
(let ([proj-x (contract-projection rngs-x)] ...)
|
||||
(make-contract
|
||||
#:name
|
||||
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(let ([p-app-x (proj-x blame)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(λ args
|
||||
(let-values ([(res-x ...) (apply val args)])
|
||||
(values (p-app-x res-x) ...)))
|
||||
(raise-blame-error blame val "expected a procedure")))))
|
||||
#:first-order procedure?))))]))
|
||||
(define ctc
|
||||
(make-contract
|
||||
#:name
|
||||
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(let ([p-app-x (proj-x blame)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(make-contracted-function
|
||||
(λ args
|
||||
(let-values ([(res-x ...) (apply val args)])
|
||||
(values (p-app-x res-x) ...)))
|
||||
ctc)
|
||||
(raise-blame-error blame val "expected a procedure")))))
|
||||
#:first-order procedure?))
|
||||
ctc)))]))
|
||||
|
||||
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
|
||||
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
|
||||
|
|
@ -88,6 +96,7 @@
|
|||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords blame)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords blame)))
|
||||
ctc
|
||||
(append partial-doms partial-ranges partial-kwds))))))
|
||||
|
||||
#:name
|
||||
|
|
@ -263,10 +272,10 @@
|
|||
[use-any? use-any?])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-names ... rng-names ... kwd-names ...)
|
||||
(lambda (chk ctc dom-names ... rng-names ... kwd-names ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(make-contracted-function inner-lambda ctc))))])
|
||||
(values
|
||||
(syntax (build--> '->
|
||||
(list dom-ctcs ...)
|
||||
|
|
@ -323,10 +332,10 @@
|
|||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
|
||||
(lambda (chk ctc dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(make-contracted-function inner-lambda ctc))))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
|
|
@ -353,10 +362,10 @@
|
|||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...)
|
||||
(lambda (chk ctc dom-x ... rst-x ignored dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(make-contracted-function inner-lambda ctc))))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
|
|
|
|||
|
|
@ -40,6 +40,10 @@ v4 todo:
|
|||
|
||||
(define-syntax-parameter making-a-method #f)
|
||||
|
||||
(define-struct contracted-function (proc ctc)
|
||||
#:property prop:procedure 0
|
||||
#:property prop:contracted 1)
|
||||
|
||||
(define-syntax (unconstrained-domain-> stx)
|
||||
(syntax-case stx ()
|
||||
[(_ rngs ...)
|
||||
|
|
@ -49,26 +53,30 @@ v4 todo:
|
|||
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
||||
(let ([proj-x (contract-projection rngs-x)] ...)
|
||||
(make-contract
|
||||
#:name
|
||||
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(let ([p-app-x (proj-x blame)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args)
|
||||
(let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
|
||||
(values (p-app-x res-x) ...)))
|
||||
(λ args
|
||||
(let-values ([(res-x ...) (apply val args)])
|
||||
(values (p-app-x res-x) ...))))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected a procedure")))))
|
||||
#:first-order
|
||||
procedure?))))]))
|
||||
(define ctc
|
||||
(make-contract
|
||||
#:name
|
||||
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(let ([p-app-x (proj-x blame)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(make-contracted-function
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args)
|
||||
(let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
|
||||
(values (p-app-x res-x) ...)))
|
||||
(λ args
|
||||
(let-values ([(res-x ...) (apply val args)])
|
||||
(values (p-app-x res-x) ...))))
|
||||
ctc)
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected a procedure")))))
|
||||
#:first-order
|
||||
procedure?))
|
||||
ctc)))]))
|
||||
|
||||
|
||||
;
|
||||
|
|
@ -132,9 +140,10 @@ v4 todo:
|
|||
optional-kwds-proj)])
|
||||
(apply func
|
||||
(λ (val mtd?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame)))
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame)))
|
||||
ctc
|
||||
(append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges))))))
|
||||
|
|
@ -358,10 +367,10 @@ v4 todo:
|
|||
(syntax (lambda args body))))]
|
||||
[use-any? use-any?])
|
||||
(with-syntax ([outer-lambda
|
||||
#`(lambda (chk dom-names ... kwd-names ... rng-names ...)
|
||||
(lambda (val)
|
||||
(chk val #,(syntax-parameter-value #'making-a-method))
|
||||
inner-lambda))])
|
||||
#`(lambda (chk ctc dom-names ... kwd-names ... rng-names ...)
|
||||
(lambda (val)
|
||||
(chk val #,(syntax-parameter-value #'making-a-method))
|
||||
(make-contracted-function inner-lambda ctc)))])
|
||||
(values
|
||||
(syntax
|
||||
(build--> '->
|
||||
|
|
@ -615,7 +624,8 @@ v4 todo:
|
|||
#'(list rng-ctc ...))
|
||||
#''())
|
||||
#,(if rng-ctc #f #t)
|
||||
(λ (chk mandatory-dom-proj ...
|
||||
(λ (chk ctc
|
||||
mandatory-dom-proj ...
|
||||
#,@(if rest-ctc
|
||||
#'(rest-proj)
|
||||
#'())
|
||||
|
|
@ -625,39 +635,42 @@ v4 todo:
|
|||
rng-proj ...)
|
||||
(λ (f)
|
||||
(chk f #,(syntax-parameter-value #'making-a-method))
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ (this-parameter ...
|
||||
mandatory-dom-arg ...
|
||||
[optional-dom-arg unspecified-dom] ...
|
||||
mandatory-dom-kwd/var-seq ...
|
||||
optional-dom-kwd/var-seq ...
|
||||
#,@(if rest-ctc #'rest #'()))
|
||||
(let*-values ([(kwds kwd-args) (values '() '())]
|
||||
[(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
|
||||
(values kwds kwd-args)
|
||||
(values (cons 'rev-sorted-dom-kwd kwds)
|
||||
(cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
|
||||
kwd-args)))]
|
||||
...
|
||||
[(opt-args) #,(if rest-ctc
|
||||
#'(rest-proj rest)
|
||||
#''())]
|
||||
[(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
|
||||
opt-args
|
||||
(cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
|
||||
...)
|
||||
#,(let ([call
|
||||
(if (null? (syntax->list #'(rev-sorted-dom-kwd ...)))
|
||||
#'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
|
||||
#'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
|
||||
(if rng-ctc
|
||||
#`(apply-projections ((rng rng-proj) ...)
|
||||
#,call)
|
||||
#;
|
||||
#`(let-values ([(rng ...) #,call])
|
||||
(values (rng-proj rng) ...))
|
||||
call))))))))))))))]))
|
||||
(make-contracted-function
|
||||
#,(maybe-a-method/name
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ (this-parameter ...
|
||||
mandatory-dom-arg ...
|
||||
[optional-dom-arg unspecified-dom] ...
|
||||
mandatory-dom-kwd/var-seq ...
|
||||
optional-dom-kwd/var-seq ...
|
||||
#,@(if rest-ctc #'rest #'()))
|
||||
(let*-values ([(kwds kwd-args) (values '() '())]
|
||||
[(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
|
||||
(values kwds kwd-args)
|
||||
(values (cons 'rev-sorted-dom-kwd kwds)
|
||||
(cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
|
||||
kwd-args)))]
|
||||
...
|
||||
[(opt-args) #,(if rest-ctc
|
||||
#'(rest-proj rest)
|
||||
#''())]
|
||||
[(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
|
||||
opt-args
|
||||
(cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
|
||||
...)
|
||||
#,(let ([call
|
||||
(if (null? (syntax->list #'(rev-sorted-dom-kwd ...)))
|
||||
#'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
|
||||
#'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
|
||||
(if rng-ctc
|
||||
#`(apply-projections ((rng rng-proj) ...)
|
||||
#,call)
|
||||
#;
|
||||
#`(let-values ([(rng ...) #,call])
|
||||
(values (rng-proj rng) ...))
|
||||
call))))))
|
||||
ctc))))))))))]))
|
||||
|
||||
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
|
||||
|
||||
|
|
@ -983,15 +996,17 @@ v4 todo:
|
|||
(loop (cdr results) (cdr result-contracts)))]))))))]
|
||||
[else
|
||||
(thunk)])))))])
|
||||
(procedure-reduce-keyword-arity
|
||||
(make-keyword-procedure kwd-proc
|
||||
((->d-name-wrapper ->d-stct)
|
||||
(λ args
|
||||
(apply kwd-proc '() '() args))))
|
||||
|
||||
arity
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-keywords ->d-stct))))))))
|
||||
(make-contracted-function
|
||||
(procedure-reduce-keyword-arity
|
||||
(make-keyword-procedure kwd-proc
|
||||
((->d-name-wrapper ->d-stct)
|
||||
(λ args
|
||||
(apply kwd-proc '() '() args))))
|
||||
|
||||
arity
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-keywords ->d-stct))
|
||||
->d-stct)))))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
(cond
|
||||
|
|
@ -1231,12 +1246,15 @@ v4 todo:
|
|||
(list rng-proj ...)
|
||||
'(spec ...)
|
||||
(λ (chk
|
||||
ctc
|
||||
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
|
||||
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
|
||||
(λ (f)
|
||||
(chk f #,(syntax-parameter-value #'making-a-method))
|
||||
(case-lambda
|
||||
[formals body] ...)))))))]))
|
||||
(make-contracted-function
|
||||
(case-lambda
|
||||
[formals body] ...)
|
||||
ctc)))))))]))
|
||||
|
||||
;; dom-ctcs : (listof (listof contract))
|
||||
;; rst-ctcs : (listof contract)
|
||||
|
|
@ -1267,11 +1285,12 @@ v4 todo:
|
|||
(for-each
|
||||
(λ (dom-length has-rest?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length '() '() blame)
|
||||
(check-procedure val mtd? dom-length 0 '() '() blame)))
|
||||
(check-procedure/more val mtd? dom-length '() '() blame)
|
||||
(check-procedure val mtd? dom-length 0 '() '() blame)))
|
||||
specs rst-ctcs)]))])
|
||||
(apply (case->-wrapper ctc)
|
||||
chk
|
||||
ctc
|
||||
projs)))))
|
||||
#:name
|
||||
(λ (ctc)
|
||||
|
|
|
|||
|
|
@ -11,9 +11,7 @@ improve method arity mismatch contract violation error messages?
|
|||
|
||||
(provide contract
|
||||
recursive-contract
|
||||
current-contract-region
|
||||
has-contract?
|
||||
get-contract)
|
||||
current-contract-region)
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/stxparam
|
||||
|
|
@ -42,26 +40,9 @@ improve method arity mismatch contract violation error messages?
|
|||
(define (apply-contract c v pos neg name loc)
|
||||
(let* ([c (coerce-contract 'contract c)])
|
||||
(check-source-location! 'contract loc)
|
||||
(remember-contract
|
||||
(((contract-projection c)
|
||||
(make-blame loc name (contract-name c) pos neg #t))
|
||||
v)
|
||||
c)))
|
||||
|
||||
(define-struct contracted-function (f contract) #:property prop:procedure 0)
|
||||
(define (remember-contract f contract)
|
||||
(cond
|
||||
[(parameter? f) f]
|
||||
[(procedure? f) (make-contracted-function f contract)]
|
||||
[else f]))
|
||||
|
||||
(define (has-contract? x) (contracted-function? x))
|
||||
(define (get-contract x)
|
||||
(unless (has-contract? x)
|
||||
(raise-type-error 'get-contract
|
||||
"<has-contract>"
|
||||
x))
|
||||
(contracted-function-contract x))
|
||||
(((contract-projection c)
|
||||
(make-blame loc name (contract-name c) pos neg #t))
|
||||
v)))
|
||||
|
||||
(define-syntax (recursive-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -39,11 +39,26 @@
|
|||
contract-first-order
|
||||
contract-first-order-passes?
|
||||
|
||||
prop:contracted
|
||||
has-contract?
|
||||
value-contract
|
||||
|
||||
;; for opters
|
||||
check-flat-contract
|
||||
check-flat-named-contract
|
||||
any)
|
||||
|
||||
(define-values (prop:contracted has-contract? value-contract)
|
||||
(let-values ([(prop pred get)
|
||||
(make-struct-type-property
|
||||
'prop:contracted
|
||||
(lambda (v si)
|
||||
(if (number? v)
|
||||
(let ([ref (cadddr si)])
|
||||
(lambda (s) (ref s v)))
|
||||
(lambda (s) v))))])
|
||||
(values prop pred (λ (v) (if (pred v) ((get v) v) #f)))))
|
||||
|
||||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide provide/contract
|
||||
(for-syntax make-provide/contract-transformer)
|
||||
get-contract
|
||||
has-contract?)
|
||||
(for-syntax make-provide/contract-transformer))
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
|
|
|
|||
|
|
@ -1328,13 +1328,14 @@ flat contracts.}
|
|||
|
||||
Extracts the predicate from a flat contract.}
|
||||
|
||||
@defproc[(get-contract [v has-contract?]) contract?]{
|
||||
Returns the contract attached to @scheme[v], if any.
|
||||
@defproc[(value-contract [v has-contract?]) contract?]{
|
||||
Returns the contract attached to @scheme[v], if recorded.
|
||||
Otherwise it returns @scheme[#f].
|
||||
}
|
||||
|
||||
@defproc[(has-contract? [v any/c]) boolean?]{
|
||||
Returns @scheme[#t] if @scheme[v] is a function that
|
||||
has a contract attached to it.
|
||||
Returns @scheme[#t] if @scheme[v] is a value that
|
||||
has a recorded contract attached to it.
|
||||
}
|
||||
|
||||
@defproc[(contract-first-order-passes? [contract contract?]
|
||||
|
|
|
|||
|
|
@ -4060,6 +4060,7 @@
|
|||
;; test error message has right format
|
||||
;;
|
||||
|
||||
#|
|
||||
(test/spec-passed/result
|
||||
'wrong-method-arity-error-message
|
||||
'(with-handlers ([exn:fail? exn-message])
|
||||
|
|
@ -4071,7 +4072,7 @@
|
|||
1
|
||||
2))
|
||||
"procedure m method: expects 1 argument, given 2: 1 2")
|
||||
|
||||
|#
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; tests object utilities to be sure wrappers work right
|
||||
|
|
@ -7641,6 +7642,43 @@ so that propagation occurs.
|
|||
'neg))
|
||||
(f 10)))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ;; ;; ;;
|
||||
; ;; ;; ;;
|
||||
; ;; ;; ;;;; ;; ;; ;; ;;;; ;;;; ;;;; ;; ;; ;;;; ;; ; ;;;; ;;;; ;;;;
|
||||
; ;;; ;; ;;;;;; ;; ;; ;; ;;;;;; ;;;;; ;;;;; ;;;;;; ;;;; ;;;; ;;;;;; ;;;;; ;;;;
|
||||
; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
|
||||
; ;; ;; ;; ;; ;; ;; ;;;;;; ;;;; ;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
|
||||
; ;; ;; ;;;;; ;; ;; ;; ;;;;;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;;;;; ;; ;;
|
||||
; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
|
||||
; ;;; ;; ;; ;; ;; ;; ;; ;; ;;;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
|
||||
; ;;; ;;;;;; ;; ;;;;;; ;;;;;; ;;;;; ;;;;; ;; ;; ;;; ;; ;;;;;; ;;;;; ;;;
|
||||
; ;;; ;; ;; ;; ;;;;; ;;;; ;;;; ;;;;; ;; ;; ;;; ;; ;; ;; ;;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(test #f value-contract #f)
|
||||
(test #f value-contract (λ (x) x))
|
||||
(test #f value-contract (unit (import) (export)))
|
||||
(test #f value-contract object%)
|
||||
|
||||
(let ([ctc (-> number? number?)])
|
||||
(test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg)))
|
||||
(let ([ctc (->* (number?) (number?) number?)])
|
||||
(test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))
|
||||
(let ([ctc (->d ([x number?]) ([y number?]) [_ number?])])
|
||||
(test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg)))
|
||||
(let ([ctc (unconstrained-domain-> number?)])
|
||||
(test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg)))
|
||||
(let ([ctc (case-> (-> number? number? number?) (-> number? number?))])
|
||||
(test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg)))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user