From bf60da75e179c2b2ecd9c09f0f7aadda629d95b5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 4 Mar 2010 21:10:44 +0000 Subject: [PATCH] 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 --- collects/mzlib/private/contract-arrow.ss | 47 +++-- collects/scheme/contract/private/arrow.ss | 167 ++++++++++-------- collects/scheme/contract/private/base.ss | 27 +-- collects/scheme/contract/private/guts.ss | 15 ++ collects/scheme/contract/private/provide.ss | 4 +- .../scribblings/reference/contracts.scrbl | 9 +- collects/tests/mzscheme/contract-test.ss | 40 ++++- 7 files changed, 185 insertions(+), 124 deletions(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 80b88f517a..2b13878178 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -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 diff --git a/collects/scheme/contract/private/arrow.ss b/collects/scheme/contract/private/arrow.ss index 7904156f1a..873f8e5450 100644 --- a/collects/scheme/contract/private/arrow.ss +++ b/collects/scheme/contract/private/arrow.ss @@ -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) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 5ac2d5cd11..13a89a2559 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -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 - "" - 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 () diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index 1d3d2225ad..bca36b3e19 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -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)) diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index ba6062afbc..41676a3895 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -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 diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 88a7720562..9e2a2ba2ac 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -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?] diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index aa38367ca2..950f18f3a7 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -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))) ; ;