From 9ba432ab9c48875b0fb1dde89199f9b9df70d5d7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 17 Mar 2008 04:01:39 +0000 Subject: [PATCH] added the _ special case to ->d svn: r8998 --- .../framework/private/framework-exports.ss | 19 +-- collects/scheme/private/contract-arrow.ss | 158 ++++++++++++------ collects/scheme/private/contract.ss | 34 ++-- .../guide/contracts-general-function.scrbl | 56 +++++++ .../scribblings/reference/contracts.scrbl | 8 + collects/tests/mzscheme/contract-test.ss | 76 +++++++++ 6 files changed, 275 insertions(+), 76 deletions(-) diff --git a/collects/framework/private/framework-exports.ss b/collects/framework/private/framework-exports.ss index 5eb7428961..019b4e6726 100644 --- a/collects/framework/private/framework-exports.ss +++ b/collects/framework/private/framework-exports.ss @@ -100,16 +100,15 @@ (preferences:add-panel (-> (or/c string? (cons/c string? (listof string?))) - (let ([old-children '()]) - (->d ([parent (is-a?/c area-container-window<%>)]) - () - #:pre-cond (set! old-children (send parent get-children)) - [child - (λ (child) - (and (is-a? child area-container-window<%>) - (andmap eq? - (append old-children (list child)) - (send parent get-children))))])) + (->d ([parent (is-a?/c area-container-window<%>)]) + () + [_ + (let ([old-children (send parent get-children)]) + (and/c (is-a?/c area-container-window<%>) + (λ (child) + (andmap eq? + (append old-children (list child)) + (send parent get-children)))))]) void?) (labels f) @{@scheme[preferences:add-preference-panel] adds the result of diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 7c964cf2bd..61f4ef2ff9 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -2,20 +2,10 @@ #| -v4 done: - -- added mandatory keywords to -> -- rewrote ->* using new notation -- rewrote ->d using new notation -- rewrote case-> -- rewrote object-contract - v4 todo: - add case-> to object-contract -- improve the generation of wrappers to avoid 'apply' and to make keywords work. - - test object-contract with keywords (both optional and mandatory) - change mzlib/contract to rewrite into scheme/contract (maybe?) @@ -776,35 +766,60 @@ v4 todo: [[id ctc] #'((id) (ctc))] [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] [mtd? (syntax-parameter-value #'making-a-method)]) - (let ([dup (check-duplicate-identifier (syntax->list #'(dom-params ... rng-params ...)))]) - (when dup - (raise-syntax-error #f "duplicate identifier" stx dup))) - #`(syntax-parameterize - ((making-a-method #f)) - (build-->d mtd? - (list (λ (dom-params ...) mandatory-doms) ...) - (list (λ (dom-params ...) optional-doms) ...) - (list (λ (dom-params ...) mandatory-kwd-dom) ...) - (list (λ (dom-params ...) optional-kwd-dom) ...) - #,(if id/rest - (with-syntax ([(id rst-ctc) id/rest]) - #`(λ (dom-params ...) rst-ctc)) - #f) - #,(if pre-cond - #`(λ (dom-params ...) #,pre-cond) - #f) - #,(syntax-case #'rng-ctcs () - [#f #f] - [(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)]) - #,(if post-cond - #`(λ (rng-params ... dom-params ...) #,post-cond) - #f) - '(mandatory-kwd ...) - '(optional-kwd ...) - (λ (f) - #,(add-name-prop - (syntax-local-infer-name stx) - #`(λ args (apply f args)))))))))))])) + (let ([rng-underscores? + (let ([is-underscore? + (λ (x) + (syntax-case x (_) + [_ #t] + [else #f]))]) + (cond + [(andmap is-underscore? (syntax->list #'(rng-params ...))) + #t] + [(ormap (λ (x) (and (is-underscore? x) x)) + (syntax->list #'(rng-params ...))) + => + (λ (id) + (raise-syntax-error '->d + "expected all of the identifiers to be underscores, or none of them to be" + stx + id))] + [else #f]))]) + (let ([dup (check-duplicate-identifier + (append (if rng-underscores? + '() + (syntax->list #'(rng-params ...))) + (syntax->list #'(dom-params ...))))]) + (when dup + (raise-syntax-error #f "duplicate identifier" stx dup))) + #`(syntax-parameterize + ((making-a-method #f)) + (build-->d mtd? + (list (λ (dom-params ...) mandatory-doms) ...) + (list (λ (dom-params ...) optional-doms) ...) + (list (λ (dom-params ...) mandatory-kwd-dom) ...) + (list (λ (dom-params ...) optional-kwd-dom) ...) + #,(if id/rest + (with-syntax ([(id rst-ctc) id/rest]) + #`(λ (dom-params ...) rst-ctc)) + #f) + #,(if pre-cond + #`(λ (dom-params ...) #,pre-cond) + #f) + #,(syntax-case #'rng-ctcs () + [#f #f] + [(ctc ...) + (if rng-underscores? + #'(box (list (λ (dom-params ...) ctc) ...)) + #'(list (λ (rng-params ... dom-params ...) ctc) ...))]) + #,(if post-cond + #`(λ (rng-params ... dom-params ...) #,post-cond) + #f) + '(mandatory-kwd ...) + '(optional-kwd ...) + (λ (f) + #,(add-name-prop + (syntax-local-infer-name stx) + #`(λ args (apply f args))))))))))))])) (define (->d-proj ->d-stct) (let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) @@ -879,12 +894,28 @@ v4 todo: (error 'shouldnt\ happen))] [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str) (loop (cdr args) - (cdr non-kwd-ctcs)))])))))]) - (if (->d-range ->d-stct) + (cdr non-kwd-ctcs)))])))))] + [rng (let ([rng (->d-range ->d-stct)]) + (cond + [(not rng) #f] + [(box? rng) + (map (λ (val) + (keyword-apply + val + kwd-args + kwd-arg-vals + (append + ;; this parameter (if necc.) + (if (->d-mtd? ->d-stct) (list (car raw-orig-args)) '()) + orig-args))) + (unbox rng))] + [else rng]))] + [rng-underscore? (box? (->d-range ->d-stct))]) + (if rng (call-with-values thnk (λ orig-results - (let* ([range-count (length (->d-range ->d-stct))] + (let* ([range-count (length rng)] [post-args (append orig-results raw-orig-args)] [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count @@ -909,21 +940,26 @@ v4 todo: (apply values (let loop ([results orig-results] - [result-contracts (->d-range ->d-stct)]) + [result-contracts rng]) (cond [(null? result-contracts) '()] [else - (cons (invoke-dep-ctc (car result-contracts) dep-post-args (car results) pos-blame neg-blame src-info orig-str) - (loop (cdr results) (cdr result-contracts)))])))))) + (cons + (invoke-dep-ctc (car result-contracts) + (if rng-underscore? #f dep-post-args) + (car results) pos-blame neg-blame src-info orig-str) + (loop (cdr results) (cdr result-contracts)))])))))) (thnk))))]) (make-keyword-procedure kwd-proc ((->d-name-wrapper ->d-stct) (λ args (apply kwd-proc '() '() args))))))))) -;; invoke-dep-ctc : (...? -> ctc) (listof tst) val pos-blame neg-blame src-info orig-src -> tst +;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst (define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str) - (let ([ctc (coerce-contract '->d (apply dep-ctc dep-args))]) + (let ([ctc (coerce-contract '->d (if dep-args + (apply dep-ctc dep-args) + dep-ctc))]) ((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str) val))) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) @@ -976,14 +1012,20 @@ v4 todo: optional-kwds name-wrapper))) +;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that +;; is under the contract, and "dr???" refers to the arguments & the results of the function that +;; is under the contract. +;; the `box' in the range only serves to differentiate between range contracts that depend on +;; both the domain and the range from those that depend only on the domain (and thus, those +;; that can be applied early) (define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. - mandatory-dom-ctcs ;; (listof (-> ??? ctc)) - optional-dom-ctcs ;; (listof (-> ??? ctc)) - keyword-ctcs ;; (listof (-> ??? ctc)) - rest-ctc ;; (or/c false/c (-> ??? ctc)) - pre-cond ;; (-> ??? boolean) - range ;; (or/c false/c (-> ??? ctc)) - post-cond ;; (-> ??? boolean) + mandatory-dom-ctcs ;; (listof (-> d??? ctc)) + optional-dom-ctcs ;; (listof (-> d??? ctc)) + keyword-ctcs ;; (listof (-> d??? ctc)) + rest-ctc ;; (or/c false/c (-> d??? ctc)) + pre-cond ;; (-> d??? boolean) + range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc)))) + post-cond ;; (-> dr??? boolean) keywords ;; (listof keywords) -- sorted by keyword< mandatory-keywords ;; (listof keywords) -- sorted by keyword< optional-keywords ;; (listof keywords) -- sorted by keyword< @@ -1019,6 +1061,14 @@ v4 todo: ,(let ([range (->d-range ctc)]) (cond [(not range) 'any] + [(box? range) + (let ([range (unbox range)]) + (cond + [(and (not (null? range)) + (null? (cdr range))) + `[_ ...]] + [else + `(values ,@(map (λ (x) `(_ ...)) range))]))] [(and (not (null? range)) (null? (cdr range))) `[,(next-id) ...]] diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index a5db45542e..ab2fb483f5 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -494,18 +494,28 @@ improve method arity mismatch contract violation error messages? (syntax-case x () [(a b) #'(slc #'b)] [else #f])) - (syntax->list #'(mutator-codes/mutator-new-names ...)))]) - (syntax (begin - (provide (rename-out [id-rename struct-name])) - (define-syntax id-rename - (let ([slc (syntax-local-certifier)]) - (list (slc #'-struct:struct-name) - (slc #'constructor-new-name) - (slc #'predicate-new-name) - (list (slc #'rev-selector-new-names) ... - (slc #'rev-selector-old-names) ...) - (list mutator-id-info ...) - super-id))))))] + (syntax->list #'(mutator-codes/mutator-new-names ...)))] + [(exported-selector-ids ...) (reverse selector-ids)] + ) + #`(begin + (provide (rename-out [id-rename struct-name])) + (define-syntax id-rename + (let ([slc (syntax-local-certifier)]) + #; + (list (slc #'-struct:struct-name) + (slc #'#,constructor-id) + (slc #'#,predicate-id) + (list (slc #'exported-selector-ids) ...) + (list mutator-id-info ...) + super-id) + ;#; + (list (slc #'-struct:struct-name) + (slc #'constructor-new-name) + (slc #'predicate-new-name) + (list (slc #'rev-selector-new-names) ... + (slc #'rev-selector-old-names) ...) + (list mutator-id-info ...) + super-id)))))] [struct:struct-name struct:struct-name] [-struct:struct-name -struct:struct-name] [struct-name struct-name] diff --git a/collects/scribblings/guide/contracts-general-function.scrbl b/collects/scribblings/guide/contracts-general-function.scrbl index a3d597f8c1..b7c4182b73 100644 --- a/collects/scribblings/guide/contracts-general-function.scrbl +++ b/collects/scribblings/guide/contracts-general-function.scrbl @@ -3,6 +3,7 @@ scribble/eval "guide-utils.ss" "contracts-utils.ss" + (for-label framework/framework) (for-label scheme/contract) (for-label scheme/gui)) @@ -395,6 +396,61 @@ balance. The resulting contract checks whether an account has a balance that is larger or smaller, depending on the given comparison operator, than the original balance. +@ctc-section[#:tag "arrow-d-eval-order"]{Ensuring that a function properly modifies state} + +The @scheme[->d] contract combinator can also ensure that a +function only modifies state according to certain +constraints. For example, consider this contract +(it is a slightly simplified from the function +@scheme[preferences:add-panel] in the framework): +@schemeblock[ +(->d ([parent (is-a?/c area-container-window<%>)]) + () + [_ + (let ([old-children (send parent get-children)]) + (λ (child) + (andmap eq? + (append old-children (list child)) + (send parent get-children))))]) +] +It says that the function accepts a single argument, named +@scheme[parent], and that @scheme[parent] must be +an object matching the interface @scheme[area-container-window<%>]. + +The range contract ensures that the function only modifies +the children of @scheme[parent] by adding a new child to the +front of the list. It accomplishes this by using the +@scheme[_] instead of a normal identifier, which tells the +contract library that the range contract does not depend on +the values of any of the results, and thus the contract +library evaluates the expression following the @scheme[_] +when the function is called, instead of when it +returns. Therefore the call to the @scheme[get-children] method +happens before the function under the contract is called. +When the function under contract returns, its result is +passed in as @scheme[child], and the contract ensures that +the children after the function return are the same as the +children before the function called, but with one more +child, at the front of the list. + +To see the difference in a toy example that focuses +on this point, consider this program +@schememod[ +scheme +(define x '()) +(define (get-x) x) +(define (f) (set! x (cons 'f x))) +(provide/contract + [f (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])] + [get-x (-> (listof symbol?))]) +] +If you were to require this module, call @scheme[f], then +the result of @scheme[get-x] would be @scheme['(f ctc)]. In +contrast, if the contract for @scheme[f] were +@schemeblock[(->d () () [res (begin (set! x (cons 'ctc x)) any/c)])] +(only changing the underscore to @scheme[res]), then +the result of @scheme[get-x] would be @scheme['(ctc f)]. + @ctc-section[#:tag "case-lambda"]{Contracts for @scheme[case-lambda]} Dybvig, in Chapter 5 of the diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index d4c1cadbc2..46614a30a5 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -417,6 +417,8 @@ symbols, and that return a symbol. [dependent-rest (code:line) (code:line #:rest id rest-expr)] [pre-cond (code:line) (code:line #:pre-cond boolean-expr)] [dep-range any + (code:line [_ range-expr] post-cond) + (code:line (values [_ range-expr] ...) post-cond) (code:line [id range-expr] post-cond) (code:line (values [id range-expr] ...) post-cond)] [post-cond (code:line) (code:line #:post-cond boolean-expr)] @@ -445,6 +447,12 @@ Each of the @scheme[id]s on an argument (including the rest argument) is visible in all of the sub-expressions of @scheme[->d]. Each of the @scheme[id]s on a result is visible in the subexpressions of the @scheme[dep-range]. + +If the identifier position of the range contract is +@scheme[_] (an underscore), then the range contract +expressions are evaluated when the function is called (and +the underscore is not bound in the range). Otherwise the +range expressions are evaluated when the function returns. } @defform*/subs[#:literals (any values ->) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 89df7ef054..9bbd720268 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -1606,6 +1606,42 @@ 'pos 'neg))) + (test/pos-blame + '->d-underscore1 + '((contract (->d ([b (box/c integer?)]) + () + [_ (let ([old (unbox b)]) + (and/c + void? + (λ (new) + (printf "old ~a new ~a\n" old (unbox b)) + (= old (unbox b)))))]) + (λ (b) + (set-box! b (+ (unbox b) 1))) + 'pos + 'neg) + (box 1))) + + (test/spec-passed/result + '->d-underscore2 + '(let ([x '()]) + ((contract (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)]) + (λ () (set! x (cons 'body x))) + 'pos + 'neg)) + x) + '(body ctc)) + + (test/spec-passed/result + '->d-underscore3 + '(let ([x '()]) + ((contract (->d () () [res (begin (set! x (cons 'ctc x)) any/c)]) + (λ () (set! x (cons 'body x))) + 'pos + 'neg)) + x) + '(ctc body)) + ; ; ; @@ -5515,6 +5551,46 @@ so that propagation occurs. (eval '(require 'provide/contract27c)) (eval 'provide/contract27ans)) "me") + + #; + (test/spec-passed/result + 'provide/contract28 + '(begin + (eval '(module provide/contract28-m1 scheme/base + (require scheme/contract) + (define-struct repair () #:transparent) + (provide/contract [struct repair ()]))) + (eval '(module provide/contract28-m2 scheme/base + (require 'provide/contract28-m1 scheme/contract) + (provide/contract [struct repair ()]))) + (eval '(module provide/contract28-m3 scheme/base + (require 'provide/contract28-m2) + (provide provide/contract28-res) + (define provide/contract28-res (repair? (make-repair))))) + (eval '(require 'provide/contract28-m3)) + (eval 'provide/contract28-res)) + #t) + + #; + (test/spec-passed/result + 'provide/contract29 + '(begin + (eval '(module provide/contract29-m1 scheme/base + (require scheme/contract) + (define-struct q (a b)) + (define-struct (repair q) (c d) #:transparent) + (provide/contract [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])]))) + (eval '(module provide/contract29-m2 scheme/base + (require 'provide/contract29-m1 scheme/contract) + (provide/contract [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])]))) + (eval '(module provide/contract29-m3 scheme/base + (require 'provide/contract29-m2) + (provide provide/contract29-res) + (define provide/contract29-res (list (repair? (make-repair 1 2 3 4)) + (repair-c (make-repair 1 2 3 4)))))) + (eval '(require 'provide/contract29-m3)) + (eval 'provide/contract29-res)) + (list #t 3)) (contract-error-test #'(begin