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

Refactor out new has-contract?/value-contract functionality so that it's

Browse Source 
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 2010-03-04 21:10:44 +00:00
parent 0d8fbe6d06
commit bf60da75e1
7 changed files with 185 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/mzlib/private/contract-arrow.ss
View File

@ -22,6 +22,10 @@
opt->* opt->*
unconstrained-domain->) unconstrained-domain->)
(define-struct contracted-function (proc ctc)
#:property prop:procedure 0
#:property prop:contracted 1)
(define-syntax (unconstrained-domain-> stx) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
@ -31,19 +35,23 @@
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(make-contract (define ctc
#:name (make-contract
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) #:name
#:projection (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
(λ (blame) #:projection
(let ([p-app-x (proj-x blame)] ...) (λ (blame)
(λ (val) (let ([p-app-x (proj-x blame)] ...)
(if (procedure? val) (λ (val)
(λ args (if (procedure? val)
(let-values ([(res-x ...) (apply val args)]) (make-contracted-function
(values (p-app-x res-x) ...))) (λ args
(raise-blame-error blame val "expected a procedure"))))) (let-values ([(res-x ...) (apply val args)])
#:first-order procedure?))))])) (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) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
@ -88,6 +96,7 @@
(if has-rest? (if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords blame) (check-procedure/more val dom-length '() mandatory-keywords blame)
(check-procedure val dom-length 0 '() mandatory-keywords blame))) (check-procedure val dom-length 0 '() mandatory-keywords blame)))
ctc
(append partial-doms partial-ranges partial-kwds)))))) (append partial-doms partial-ranges partial-kwds))))))
#:name #:name
@ -263,10 +272,10 @@
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(syntax (syntax
(lambda (chk dom-names ... rng-names ... kwd-names ...) (lambda (chk ctc dom-names ... rng-names ... kwd-names ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) (make-contracted-function inner-lambda ctc))))])
(values (values
(syntax (build--> '-> (syntax (build--> '->
(list dom-ctcs ...) (list dom-ctcs ...)
@ -323,10 +332,10 @@
(syntax (lambda args body))))]) (syntax (lambda args body))))])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(syntax (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) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) (make-contracted-function inner-lambda ctc))))])
(values (syntax (build--> '->* (values (syntax (build--> '->*
(list doms ...) (list doms ...)
rst rst
@ -353,10 +362,10 @@
(syntax (lambda args body))))]) (syntax (lambda args body))))])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(syntax (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) (lambda (val)
(chk val) (chk val)
inner-lambda)))]) (make-contracted-function inner-lambda ctc))))])
(values (syntax (build--> '->* (values (syntax (build--> '->*
(list doms ...) (list doms ...)
rst rst

165
collects/scheme/contract/private/arrow.ss
View File

@ -40,6 +40,10 @@ v4 todo:
(define-syntax-parameter making-a-method #f) (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) (define-syntax (unconstrained-domain-> stx)
(syntax-case stx () (syntax-case stx ()
[(_ rngs ...) [(_ rngs ...)
@ -49,26 +53,30 @@ v4 todo:
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(make-contract (define ctc
#:name (make-contract
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) #:name
#:projection (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
(λ (blame) #:projection
(let ([p-app-x (proj-x blame)] ...) (λ (blame)
(λ (val) (let ([p-app-x (proj-x blame)] ...)
(if (procedure? val) (λ (val)
(make-keyword-procedure (if (procedure? val)
(λ (kwds kwd-vals . args) (make-contracted-function
(let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)]) (make-keyword-procedure
(values (p-app-x res-x) ...))) (λ (kwds kwd-vals . args)
(λ args (let-values ([(res-x ...) (keyword-apply val kwds kwd-vals args)])
(let-values ([(res-x ...) (apply val args)]) (values (p-app-x res-x) ...)))
(values (p-app-x res-x) ...)))) (λ args
(raise-blame-error blame (let-values ([(res-x ...) (apply val args)])
val (values (p-app-x res-x) ...))))
"expected a procedure"))))) ctc)
#:first-order (raise-blame-error blame
procedure?))))])) val
"expected a procedure")))))
#:first-order
procedure?))
ctc)))]))
; ;
@ -132,9 +140,10 @@ v4 todo:
optional-kwds-proj)]) optional-kwds-proj)])
(apply func (apply func
(λ (val mtd?) (λ (val mtd?)
(if has-rest? (if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame) (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))) (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame)))
ctc
(append partial-doms partial-optional-doms (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds partial-mandatory-kwds partial-optional-kwds
partial-ranges)))))) partial-ranges))))))
@ -358,10 +367,10 @@ v4 todo:
(syntax (lambda args body))))] (syntax (lambda args body))))]
[use-any? use-any?]) [use-any? use-any?])
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
#`(lambda (chk dom-names ... kwd-names ... rng-names ...) #`(lambda (chk ctc dom-names ... kwd-names ... rng-names ...)
(lambda (val) (lambda (val)
(chk val #,(syntax-parameter-value #'making-a-method)) (chk val #,(syntax-parameter-value #'making-a-method))
inner-lambda))]) (make-contracted-function inner-lambda ctc)))])
(values (values
(syntax (syntax
(build--> '-> (build--> '->
@ -615,7 +624,8 @@ v4 todo:
#'(list rng-ctc ...)) #'(list rng-ctc ...))
#''()) #''())
#,(if rng-ctc #f #t) #,(if rng-ctc #f #t)
(λ (chk mandatory-dom-proj ... (λ (chk ctc
mandatory-dom-proj ...
#,@(if rest-ctc #,@(if rest-ctc
#'(rest-proj) #'(rest-proj)
#'()) #'())
@ -625,39 +635,42 @@ v4 todo:
rng-proj ...) rng-proj ...)
(λ (f) (λ (f)
(chk f #,(syntax-parameter-value #'making-a-method)) (chk f #,(syntax-parameter-value #'making-a-method))
#,(add-name-prop (make-contracted-function
(syntax-local-infer-name stx) #,(maybe-a-method/name
#`(λ (this-parameter ... (add-name-prop
mandatory-dom-arg ... (syntax-local-infer-name stx)
[optional-dom-arg unspecified-dom] ... #`(λ (this-parameter ...
mandatory-dom-kwd/var-seq ... mandatory-dom-arg ...
optional-dom-kwd/var-seq ... [optional-dom-arg unspecified-dom] ...
#,@(if rest-ctc #'rest #'())) mandatory-dom-kwd/var-seq ...
(let*-values ([(kwds kwd-args) (values '() '())] optional-dom-kwd/var-seq ...
[(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg) #,@(if rest-ctc #'rest #'()))
(values kwds kwd-args) (let*-values ([(kwds kwd-args) (values '() '())]
(values (cons 'rev-sorted-dom-kwd kwds) [(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
(cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg) (values kwds kwd-args)
kwd-args)))] (values (cons 'rev-sorted-dom-kwd kwds)
... (cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
[(opt-args) #,(if rest-ctc kwd-args)))]
#'(rest-proj rest) ...
#''())] [(opt-args) #,(if rest-ctc
[(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg) #'(rest-proj rest)
opt-args #''())]
(cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))] [(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
...) opt-args
#,(let ([call (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
(if (null? (syntax->list #'(rev-sorted-dom-kwd ...))) ...)
#'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args) #,(let ([call
#'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))]) (if (null? (syntax->list #'(rev-sorted-dom-kwd ...)))
(if rng-ctc #'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args)
#`(apply-projections ((rng rng-proj) ...) #'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))])
#,call) (if rng-ctc
#; #`(apply-projections ((rng rng-proj) ...)
#`(let-values ([(rng ...) #,call]) #,call)
(values (rng-proj rng) ...)) #;
call))))))))))))))])) #`(let-values ([(rng ...) #,call])
(values (rng-proj rng) ...))
call))))))
ctc))))))))))]))
(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx))) (define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))
@ -983,15 +996,17 @@ v4 todo:
(loop (cdr results) (cdr result-contracts)))]))))))] (loop (cdr results) (cdr result-contracts)))]))))))]
[else [else
(thunk)])))))]) (thunk)])))))])
(procedure-reduce-keyword-arity (make-contracted-function
(make-keyword-procedure kwd-proc (procedure-reduce-keyword-arity
((->d-name-wrapper ->d-stct) (make-keyword-procedure kwd-proc
(λ args ((->d-name-wrapper ->d-stct)
(apply kwd-proc '() '() args)))) (λ args
(apply kwd-proc '() '() args))))
arity arity
(->d-mandatory-keywords ->d-stct) (->d-mandatory-keywords ->d-stct)
(->d-keywords ->d-stct)))))))) (->d-keywords ->d-stct))
->d-stct)))))))
(define (build-values-string desc dep-pre-args) (define (build-values-string desc dep-pre-args)
(cond (cond
@ -1231,12 +1246,15 @@ v4 todo:
(list rng-proj ...) (list rng-proj ...)
'(spec ...) '(spec ...)
(λ (chk (λ (chk
ctc
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f) (λ (f)
(chk f #,(syntax-parameter-value #'making-a-method)) (chk f #,(syntax-parameter-value #'making-a-method))
(case-lambda (make-contracted-function
[formals body] ...)))))))])) (case-lambda
[formals body] ...)
ctc)))))))]))
;; dom-ctcs : (listof (listof contract)) ;; dom-ctcs : (listof (listof contract))
;; rst-ctcs : (listof contract) ;; rst-ctcs : (listof contract)
@ -1267,11 +1285,12 @@ v4 todo:
(for-each (for-each
(λ (dom-length has-rest?) (λ (dom-length has-rest?)
(if has-rest? (if has-rest?
(check-procedure/more val mtd? dom-length '() '() blame) (check-procedure/more val mtd? dom-length '() '() blame)
(check-procedure val mtd? dom-length 0 '() '() blame))) (check-procedure val mtd? dom-length 0 '() '() blame)))
specs rst-ctcs)]))]) specs rst-ctcs)]))])
(apply (case->-wrapper ctc) (apply (case->-wrapper ctc)
chk chk
ctc
projs))))) projs)))))
#:name #:name
(λ (ctc) (λ (ctc)

27
collects/scheme/contract/private/base.ss
View File

@ -11,9 +11,7 @@ improve method arity mismatch contract violation error messages?
(provide contract (provide contract
recursive-contract recursive-contract
current-contract-region current-contract-region)
has-contract?
get-contract)
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
scheme/stxparam scheme/stxparam
@ -42,26 +40,9 @@ improve method arity mismatch contract violation error messages?
(define (apply-contract c v pos neg name loc) (define (apply-contract c v pos neg name loc)
(let* ([c (coerce-contract 'contract c)]) (let* ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc) (check-source-location! 'contract loc)
(remember-contract (((contract-projection c)
(((contract-projection c) (make-blame loc name (contract-name c) pos neg #t))
(make-blame loc name (contract-name c) pos neg #t)) v)))
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))
(define-syntax (recursive-contract stx) (define-syntax (recursive-contract stx)
(syntax-case stx () (syntax-case stx ()

15
collects/scheme/contract/private/guts.ss
View File

@ -39,11 +39,26 @@
contract-first-order contract-first-order
contract-first-order-passes? contract-first-order-passes?
prop:contracted
has-contract?
value-contract
;; for opters ;; for opters
check-flat-contract check-flat-contract
check-flat-named-contract check-flat-named-contract
any) 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) (define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))

4
collects/scheme/contract/private/provide.ss
View File

@ -1,9 +1,7 @@
#lang scheme/base #lang scheme/base
(provide provide/contract (provide provide/contract
(for-syntax make-provide/contract-transformer) (for-syntax make-provide/contract-transformer))
get-contract
has-contract?)
(require (for-syntax scheme/base (require (for-syntax scheme/base
scheme/list scheme/list

9
collects/scribblings/reference/contracts.scrbl
View File

@ -1328,13 +1328,14 @@ flat contracts.}
Extracts the predicate from a flat contract.} Extracts the predicate from a flat contract.}
@defproc[(get-contract [v has-contract?]) contract?]{ @defproc[(value-contract [v has-contract?]) contract?]{
Returns the contract attached to @scheme[v], if any. Returns the contract attached to @scheme[v], if recorded.
Otherwise it returns @scheme[#f].
} }
@defproc[(has-contract? [v any/c]) boolean?]{ @defproc[(has-contract? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a function that Returns @scheme[#t] if @scheme[v] is a value that
has a contract attached to it. has a recorded contract attached to it.
} }
@defproc[(contract-first-order-passes? [contract contract?] @defproc[(contract-first-order-passes? [contract contract?]

40
collects/tests/mzscheme/contract-test.ss
View File

@ -4060,6 +4060,7 @@
;; test error message has right format ;; test error message has right format
;; ;;
#|
(test/spec-passed/result (test/spec-passed/result
'wrong-method-arity-error-message 'wrong-method-arity-error-message
'(with-handlers ([exn:fail? exn-message]) '(with-handlers ([exn:fail? exn-message])
@ -4071,7 +4072,7 @@
1 1
2)) 2))
"procedure m method: expects 1 argument, given 2: 1 2") "procedure m method: expects 1 argument, given 2: 1 2")
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; tests object utilities to be sure wrappers work right ;; tests object utilities to be sure wrappers work right
@ -7642,6 +7643,43 @@ so that propagation occurs.
(f 10))) (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)))
; ;
; ;
; ;